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
fix uninitialized memory reads found by purify
[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
JH		 600 {
601 RESTORE_NUMERIC_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;
3280af22 728 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
a0d0e21e
LW		 729 I32 count;
730 I32 shift;
731 SV** src;
732 SV** dst;
733
3280af22 734 ++PL_markstack_ptr[-1];
a0d0e21e 735 if (diff) {
3280af22
NIS		 736 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
737 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
738 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
a0d0e21e 739
924508f0
GS		 740 EXTEND(SP,shift);
741 src = SP;
742 dst = (SP += shift);
3280af22
NIS		 743 PL_markstack_ptr[-1] += shift;
744 *PL_markstack_ptr += shift;
a0d0e21e
LW		 745 while (--count)
746 *dst-- = *src--;
747 }
3280af22 748 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
a0d0e21e
LW		 749 ++diff;
750 while (--diff)
751 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
752 }
753 LEAVE; /* exit inner scope */
754
755 /* All done yet? */
3280af22 756 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e 757 I32 items;
54310121 758 I32 gimme = GIMME_V;
a0d0e21e
LW		 759
760 (void)POPMARK; /* pop top */
761 LEAVE; /* exit outer scope */
762 (void)POPMARK; /* pop src */
3280af22 763 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 764 (void)POPMARK; /* pop dst */
3280af22 765 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 766 if (gimme == G_SCALAR) {
a0d0e21e
LW		 767 dTARGET;
768 XPUSHi(items);
a0d0e21e 769 }
54310121 770 else if (gimme == G_ARRAY)
771 SP += items;
a0d0e21e
LW		 772 RETURN;
773 }
774 else {
775 SV *src;
776
777 ENTER; /* enter inner scope */
7766f137 778 SAVEVPTR(PL_curpm);
a0d0e21e 779
3280af22 780 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 781 SvTEMP_off(src);
54b9620d 782 DEFSV = src;
a0d0e21e
LW		 783
784 RETURNOP(cLOGOP->op_other);
785 }
786}
787
a0d0e21e
LW		 788PP(pp_sort)
789{
4e35701f 790 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 791 register SV **up;
792 SV **myorigmark = ORIGMARK;
793 register I32 max;
794 HV *stash;
795 GV *gv;
796 CV *cv;
797 I32 gimme = GIMME;
533c011a 798 OP* nextop = PL_op->op_next;
d0ecd44c 799 I32 overloading = 0;
43481408
GS		 800 bool hasargs = FALSE;
801 I32 is_xsub = 0;
a0d0e21e
LW		 802
803 if (gimme != G_ARRAY) {
804 SP = MARK;
805 RETPUSHUNDEF;
806 }
807
d0abe6c5 808 ENTER;
7766f137 809 SAVEVPTR(PL_sortcop);
533c011a
NIS		 810 if (PL_op->op_flags & OPf_STACKED) {
811 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 812 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
813 kid = kUNOP->op_first; /* pass rv2gv */
814 kid = kUNOP->op_first; /* pass leave */
3280af22 815 PL_sortcop = kid->op_next;
11faa288 816 stash = CopSTASH(PL_curcop);
a0d0e21e
LW		 817 }
818 else {
819 cv = sv_2cv(*++MARK, &stash, &gv, 0);
43481408
GS		 820 if (cv && SvPOK(cv)) {
821 STRLEN n_a;
822 char *proto = SvPV((SV*)cv, n_a);
823 if (proto && strEQ(proto, "$$")) {
824 hasargs = TRUE;
825 }
826 }
a0d0e21e 827 if (!(cv && CvROOT(cv))) {
43481408
GS		 828 if (cv && CvXSUB(cv)) {
829 is_xsub = 1;
830 }
831 else if (gv) {
a0d0e21e 832 SV *tmpstr = sv_newmortal();
e5cf08de 833 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 834 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
a0d0e21e
LW		 835 SvPVX(tmpstr));
836 }
43481408 837 else {
cea2e8a9 838 DIE(aTHX_ "Undefined subroutine in sort");
a0d0e21e 839 }
a0d0e21e 840 }
b3933176 841
43481408
GS		 842 if (is_xsub)
843 PL_sortcop = (OP*)cv;
844 else {
845 PL_sortcop = CvSTART(cv);
846 SAVEVPTR(CvROOT(cv)->op_ppaddr);
847 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
848
849 SAVEVPTR(PL_curpad);
850 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
851 }
a0d0e21e
LW		 852 }
853 }
854 else {
3280af22 855 PL_sortcop = Nullop;
11faa288 856 stash = CopSTASH(PL_curcop);
a0d0e21e
LW		 857 }
858
859 up = myorigmark + 1;
860 while (MARK < SP) { /* This may or may not shift down one here. */
861 /*SUPPRESS 560*/
862 if (*up = *++MARK) { /* Weed out nulls. */
9f8d30d5 863 SvTEMP_off(*up);
d0ecd44c 864 if (!PL_sortcop && !SvPOK(*up)) {
2d8e6c8d 865 STRLEN n_a;
d0ecd44c
IZ		 866 if (SvAMAGIC(*up))
867 overloading = 1;
868 else
2d8e6c8d 869 (void)sv_2pv(*up, &n_a);
d0ecd44c 870 }
a0d0e21e
LW		 871 up++;
872 }
873 }
874 max = --up - myorigmark;
3280af22 875 if (PL_sortcop) {
a0d0e21e 876 if (max > 1) {
c09156bb 877 PERL_CONTEXT *cx;
a0d0e21e 878 SV** newsp;
54310121 879 bool oldcatch = CATCH_GET;
a0d0e21e
LW		 880
881 SAVETMPS;
462e5cf6 882 SAVEOP();
a0d0e21e 883
54310121 884 CATCH_SET(TRUE);
e788e7d3 885 PUSHSTACKi(PERLSI_SORT);
3280af22
NIS		 886 if (PL_sortstash != stash) {
887 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
888 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
889 PL_sortstash = stash;
a0d0e21e
LW		 890 }
891
3280af22
NIS		 892 SAVESPTR(GvSV(PL_firstgv));
893 SAVESPTR(GvSV(PL_secondgv));
b3933176 894
3280af22 895 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
533c011a 896 if (!(PL_op->op_flags & OPf_SPECIAL)) {
b3933176
CS		 897 cx->cx_type = CXt_SUB;
898 cx->blk_gimme = G_SCALAR;
899 PUSHSUB(cx);
900 if (!CvDEPTH(cv))
3e3baf6d 901 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
b3933176 902 }
3280af22 903 PL_sortcxix = cxstack_ix;
43481408
GS		 904
905 if (hasargs && !is_xsub) {
906 /* This is mostly copied from pp_entersub */
907 AV *av = (AV*)PL_curpad[0];
908
909#ifndef USE_THREADS
910 cx->blk_sub.savearray = GvAV(PL_defgv);
911 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
912#endif /* USE_THREADS */
913 cx->blk_sub.argarray = av;
914 }
915 qsortsv((myorigmark+1), max,
916 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
a0d0e21e 917
3280af22 918 POPBLOCK(cx,PL_curpm);
ebafeae7 919 PL_stack_sp = newsp;
d3acc0f7 920 POPSTACK;
54310121 921 CATCH_SET(oldcatch);
a0d0e21e 922 }
a0d0e21e
LW		 923 }
924 else {
925 if (max > 1) {
926 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
745d3a65 927 qsortsv(ORIGMARK+1, max,
9c007264
JH		 928 (PL_op->op_private & OPpSORT_NUMERIC)
929 ? ( (PL_op->op_private & OPpSORT_INTEGER)
0b94c7bb
GS		 930 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
931 : ( overloading ? amagic_ncmp : sv_ncmp))
9c007264
JH		 932 : ( (PL_op->op_private & OPpLOCALE)
933 ? ( overloading
0b94c7bb
GS		 934 ? amagic_cmp_locale
935 : sv_cmp_locale_static)
936 : ( overloading ? amagic_cmp : sv_cmp_static)));
9c007264
JH		 937 if (PL_op->op_private & OPpSORT_REVERSE) {
938 SV **p = ORIGMARK+1;
939 SV **q = ORIGMARK+max;
940 while (p < q) {
941 SV *tmp = *p;
942 *p++ = *q;
943 *q-- = tmp;
944 }
945 }
a0d0e21e
LW		 946 }
947 }
d0abe6c5 948 LEAVE;
3280af22 949 PL_stack_sp = ORIGMARK + max;
a0d0e21e
LW		 950 return nextop;
951}
952
953/* Range stuff. */
954
955PP(pp_range)
956{
957 if (GIMME == G_ARRAY)
1a67a97c 958 return NORMAL;
538573f7 959 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 960 return cLOGOP->op_other;
538573f7 961 else
1a67a97c 962 return NORMAL;
a0d0e21e
LW		 963}
964
965PP(pp_flip)
966{
4e35701f 967 djSP;
a0d0e21e
LW		 968
969 if (GIMME == G_ARRAY) {
1a67a97c 970 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 971 }
972 else {
973 dTOPss;
533c011a 974 SV *targ = PAD_SV(PL_op->op_targ);
a0d0e21e 975
533c011a 976 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 977 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW		 978 : SvTRUE(sv) ) {
979 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 980 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 981 sv_setiv(targ, 1);
3e3baf6d 982 SETs(targ);
a0d0e21e
LW		 983 RETURN;
984 }
985 else {
986 sv_setiv(targ, 0);
924508f0 987 SP--;
1a67a97c 988 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 989 }
990 }
991 sv_setpv(TARG, "");
992 SETs(targ);
993 RETURN;
994 }
995}
996
997PP(pp_flop)
998{
4e35701f 999 djSP;
a0d0e21e
LW		 1000
1001 if (GIMME == G_ARRAY) {
1002 dPOPPOPssrl;
c1ab3db2 1003 register I32 i, j;
a0d0e21e
LW		 1004 register SV *sv;
1005 I32 max;
86cb7173
HS		 1006
1007 if (SvGMAGICAL(left))
1008 mg_get(left);
1009 if (SvGMAGICAL(right))
1010 mg_get(right);
a0d0e21e 1011
4633a7c4 1012 if (SvNIOKp(left) || !SvPOKp(left) ||
39eb4040
GS		 1013 SvNIOKp(right) || !SvPOKp(right) ||
1014 (looks_like_number(left) && *SvPVX(left) != '0' &&
1015 looks_like_number(right) && *SvPVX(right) != '0'))
bbce6d69 1016 {
c1ab3db2 1017 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
d470f89e 1018 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1019 i = SvIV(left);
1020 max = SvIV(right);
bbce6d69 1021 if (max >= i) {
c1ab3db2
AK		 1022 j = max - i + 1;
1023 EXTEND_MORTAL(j);
1024 EXTEND(SP, j);
bbce6d69 1025 }
c1ab3db2
AK		 1026 else
1027 j = 0;
1028 while (j--) {
bbce6d69 1029 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1030 PUSHs(sv);
1031 }
1032 }
1033 else {
1034 SV *final = sv_mortalcopy(right);
2d8e6c8d 1035 STRLEN len, n_a;
a0d0e21e
LW		 1036 char *tmps = SvPV(final, len);
1037
1038 sv = sv_mortalcopy(left);
2d8e6c8d 1039 SvPV_force(sv,n_a);
89ea2908 1040 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1041 XPUSHs(sv);
89ea2908
GA		 1042 if (strEQ(SvPVX(sv),tmps))
1043 break;
a0d0e21e
LW		 1044 sv = sv_2mortal(newSVsv(sv));
1045 sv_inc(sv);
1046 }
a0d0e21e
LW		 1047 }
1048 }
1049 else {
1050 dTOPss;
1051 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1052 sv_inc(targ);
533c011a 1053 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1054 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW		 1055 : SvTRUE(sv) ) {
1056 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1057 sv_catpv(targ, "E0");
1058 }
1059 SETs(targ);
1060 }
1061
1062 RETURN;
1063}
1064
1065/* Control. */
1066
76e3520e 1067STATIC I32
cea2e8a9 1068S_dopoptolabel(pTHX_ char *label)
a0d0e21e 1069{
11343788 1070 dTHR;
a0d0e21e 1071 register I32 i;
c09156bb 1072 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1073
1074 for (i = cxstack_ix; i >= 0; i--) {
1075 cx = &cxstack[i];
6b35e009 1076 switch (CxTYPE(cx)) {
a0d0e21e 1077 case CXt_SUBST:
599cee73 1078 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1079 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1080 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1081 break;
1082 case CXt_SUB:
599cee73 1083 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1084 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1085 PL_op_name[PL_op->op_type]);
a0d0e21e 1086 break;
7766f137
GS		 1087 case CXt_FORMAT:
1088 if (ckWARN(WARN_UNSAFE))
1089 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1090 PL_op_name[PL_op->op_type]);
1091 break;
a0d0e21e 1092 case CXt_EVAL:
599cee73 1093 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1094 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1095 PL_op_name[PL_op->op_type]);
a0d0e21e 1096 break;
0a753a76 1097 case CXt_NULL:
599cee73 1098 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1099 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1100 PL_op_name[PL_op->op_type]);
0a753a76 1101 return -1;
a0d0e21e
LW		 1102 case CXt_LOOP:
1103 if (!cx->blk_loop.label ||
1104 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1105 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1106 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1107 continue;
1108 }
cea2e8a9 1109 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1110 return i;
1111 }
1112 }
1113 return i;
1114}
1115
e50aee73 1116I32
864dbfa3 1117Perl_dowantarray(pTHX)
e50aee73 1118{
54310121 1119 I32 gimme = block_gimme();
1120 return (gimme == G_VOID) ? G_SCALAR : gimme;
1121}
1122
1123I32
864dbfa3 1124Perl_block_gimme(pTHX)
54310121 1125{
11343788 1126 dTHR;
e50aee73
AD		 1127 I32 cxix;
1128
1129 cxix = dopoptosub(cxstack_ix);
1130 if (cxix < 0)
46fc3d4c 1131 return G_VOID;
e50aee73 1132
54310121 1133 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1134 case G_VOID:
1135 return G_VOID;
54310121 1136 case G_SCALAR:
e50aee73 1137 return G_SCALAR;
54310121 1138 case G_ARRAY:
1139 return G_ARRAY;
1140 default:
cea2e8a9 1141 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1142 /* NOTREACHED */
1143 return 0;
54310121 1144 }
e50aee73
AD		 1145}
1146
76e3520e 1147STATIC I32
cea2e8a9 1148S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1149{
11343788 1150 dTHR;
2c375eb9
GS		 1151 return dopoptosub_at(cxstack, startingblock);
1152}
1153
1154STATIC I32
cea2e8a9 1155S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9
GS		 1156{
1157 dTHR;
a0d0e21e 1158 I32 i;
c09156bb 1159 register PERL_CONTEXT *cx;
a0d0e21e 1160 for (i = startingblock; i >= 0; i--) {
2c375eb9 1161 cx = &cxstk[i];
6b35e009 1162 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1163 default:
1164 continue;
1165 case CXt_EVAL:
1166 case CXt_SUB:
7766f137 1167 case CXt_FORMAT:
cea2e8a9 1168 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1169 return i;
1170 }
1171 }
1172 return i;
1173}
1174
76e3520e 1175STATIC I32
cea2e8a9 1176S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1177{
11343788 1178 dTHR;
a0d0e21e 1179 I32 i;
c09156bb 1180 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1181 for (i = startingblock; i >= 0; i--) {
1182 cx = &cxstack[i];
6b35e009 1183 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1184 default:
1185 continue;
1186 case CXt_EVAL:
cea2e8a9 1187 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1188 return i;
1189 }
1190 }
1191 return i;
1192}
1193
76e3520e 1194STATIC I32
cea2e8a9 1195S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1196{
11343788 1197 dTHR;
a0d0e21e 1198 I32 i;
c09156bb 1199 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1200 for (i = startingblock; i >= 0; i--) {
1201 cx = &cxstack[i];
6b35e009 1202 switch (CxTYPE(cx)) {
a0d0e21e 1203 case CXt_SUBST:
599cee73 1204 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1205 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1206 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1207 break;
1208 case CXt_SUB:
599cee73 1209 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1210 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1211 PL_op_name[PL_op->op_type]);
a0d0e21e 1212 break;
7766f137
GS		 1213 case CXt_FORMAT:
1214 if (ckWARN(WARN_UNSAFE))
1215 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1216 PL_op_name[PL_op->op_type]);
1217 break;
a0d0e21e 1218 case CXt_EVAL:
599cee73 1219 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1220 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1221 PL_op_name[PL_op->op_type]);
a0d0e21e 1222 break;
0a753a76 1223 case CXt_NULL:
599cee73 1224 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1225 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1226 PL_op_name[PL_op->op_type]);
0a753a76 1227 return -1;
a0d0e21e 1228 case CXt_LOOP:
cea2e8a9 1229 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1230 return i;
1231 }
1232 }
1233 return i;
1234}
1235
1236void
864dbfa3 1237Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1238{
11343788 1239 dTHR;
c09156bb 1240 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1241 SV **newsp;
1242 I32 optype;
1243
1244 while (cxstack_ix > cxix) {
b0d9ce38 1245 SV *sv;
c90c0ff4 1246 cx = &cxstack[cxstack_ix];
1247 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1248 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1249 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1250 switch (CxTYPE(cx)) {
c90c0ff4 1251 case CXt_SUBST:
1252 POPSUBST(cx);
1253 continue; /* not break */
a0d0e21e 1254 case CXt_SUB:
b0d9ce38
GS		 1255 POPSUB(cx,sv);
1256 LEAVESUB(sv);
a0d0e21e
LW		 1257 break;
1258 case CXt_EVAL:
1259 POPEVAL(cx);
1260 break;
1261 case CXt_LOOP:
1262 POPLOOP(cx);
1263 break;
0a753a76 1264 case CXt_NULL:
a0d0e21e 1265 break;
7766f137
GS		 1266 case CXt_FORMAT:
1267 POPFORMAT(cx);
1268 break;
a0d0e21e 1269 }
c90c0ff4 1270 cxstack_ix--;
a0d0e21e
LW		 1271 }
1272}
1273
067f92a0
GS		 1274/*
1275 * Closures mentioned at top level of eval cannot be referenced
1276 * again, and their presence indirectly causes a memory leak.
1277 * (Note that the fact that compcv and friends are still set here
1278 * is, AFAIK, an accident.) --Chip
1279 *
1280 * XXX need to get comppad et al from eval's cv rather than
1281 * relying on the incidental global values.
1282 */
1283STATIC void
cea2e8a9 1284S_free_closures(pTHX)
067f92a0
GS		 1285{
1286 dTHR;
1287 SV **svp = AvARRAY(PL_comppad_name);
1288 I32 ix;
1289 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1290 SV *sv = svp[ix];
1291 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1292 SvREFCNT_dec(sv);
1293 svp[ix] = &PL_sv_undef;
1294
1295 sv = PL_curpad[ix];
1296 if (CvCLONE(sv)) {
1297 SvREFCNT_dec(CvOUTSIDE(sv));
1298 CvOUTSIDE(sv) = Nullcv;
1299 }
1300 else {
1301 SvREFCNT_dec(sv);
1302 sv = NEWSV(0,0);
1303 SvPADTMP_on(sv);
1304 PL_curpad[ix] = sv;
1305 }
1306 }
1307 }
1308}
1309
5a844595
GS		 1310void
1311Perl_qerror(pTHX_ SV *err)
1312{
1313 if (PL_in_eval)
1314 sv_catsv(ERRSV, err);
1315 else if (PL_errors)
1316 sv_catsv(PL_errors, err);
1317 else
894356b3 1318 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS		 1319 ++PL_error_count;
1320}
1321
a0d0e21e 1322OP *
864dbfa3 1323Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1324{
e336de0d 1325 dSP;
2d8e6c8d 1326 STRLEN n_a;
3280af22 1327 if (PL_in_eval) {
a0d0e21e 1328 I32 cxix;
c09156bb 1329 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1330 I32 gimme;
1331 SV **newsp;
1332
4e6ea2c3 1333 if (message) {
faef0170 1334 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS		 1335 static char prefix[] = "\t(in cleanup) ";
1336 SV *err = ERRSV;
1337 char *e = Nullch;
1338 if (!SvPOK(err))
1339 sv_setpv(err,"");
1340 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1341 e = SvPV(err, n_a);
1342 e += n_a - msglen;
1343 if (*e != *message || strNE(e,message))
1344 e = Nullch;
1345 }
1346 if (!e) {
1347 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1348 sv_catpvn(err, prefix, sizeof(prefix)-1);
1349 sv_catpvn(err, message, msglen);
1350 if (ckWARN(WARN_UNSAFE)) {
1351 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1352 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
4e6ea2c3 1353 }
4633a7c4 1354 }
4633a7c4 1355 }
4e6ea2c3 1356 else
06bf62c7 1357 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW		 1358 }
1359 else
06bf62c7 1360 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1361
5a844595
GS		 1362 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1363 && PL_curstackinfo->si_prev)
1364 {
bac4b2ad 1365 dounwind(-1);
d3acc0f7 1366 POPSTACK;
bac4b2ad 1367 }
e336de0d 1368
a0d0e21e
LW		 1369 if (cxix >= 0) {
1370 I32 optype;
1371
1372 if (cxix < cxstack_ix)
1373 dounwind(cxix);
1374
3280af22 1375 POPBLOCK(cx,PL_curpm);
6b35e009 1376 if (CxTYPE(cx) != CXt_EVAL) {
bf49b057
GS		 1377 PerlIO_write(Perl_error_log, "panic: die ", 11);
1378 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1379 my_exit(1);
1380 }
1381 POPEVAL(cx);
1382
1383 if (gimme == G_SCALAR)
3280af22
NIS		 1384 *++newsp = &PL_sv_undef;
1385 PL_stack_sp = newsp;
a0d0e21e
LW		 1386
1387 LEAVE;
748a9306 1388
7a2e2cd6 1389 if (optype == OP_REQUIRE) {
2d8e6c8d 1390 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 1391 DIE(aTHX_ "%sCompilation failed in require",
1392 *msg ? msg : "Unknown error\n");
7a2e2cd6 1393 }
a0d0e21e
LW		 1394 return pop_return();
1395 }
1396 }
9cc2fdd3 1397 if (!message)
06bf62c7 1398 message = SvPVx(ERRSV, msglen);
d175a3f0
GS		 1399 {
1400#ifdef USE_SFIO
1401 /* SFIO can really mess with your errno */
1402 int e = errno;
1403#endif
bf49b057
GS		 1404 PerlIO *serr = Perl_error_log;
1405
1406 PerlIO_write(serr, message, msglen);
1407 (void)PerlIO_flush(serr);
d175a3f0
GS		 1408#ifdef USE_SFIO
1409 errno = e;
1410#endif
1411 }
f86702cc 1412 my_failure_exit();
1413 /* NOTREACHED */
a0d0e21e
LW		 1414 return 0;
1415}
1416
1417PP(pp_xor)
1418{
4e35701f 1419 djSP; dPOPTOPssrl;
a0d0e21e
LW		 1420 if (SvTRUE(left) != SvTRUE(right))
1421 RETSETYES;
1422 else
1423 RETSETNO;
1424}
1425
1426PP(pp_andassign)
1427{
4e35701f 1428 djSP;
a0d0e21e
LW		 1429 if (!SvTRUE(TOPs))
1430 RETURN;
1431 else
1432 RETURNOP(cLOGOP->op_other);
1433}
1434
1435PP(pp_orassign)
1436{
4e35701f 1437 djSP;
a0d0e21e
LW		 1438 if (SvTRUE(TOPs))
1439 RETURN;
1440 else
1441 RETURNOP(cLOGOP->op_other);
1442}
1443
a0d0e21e
LW		 1444PP(pp_caller)
1445{
4e35701f 1446 djSP;
a0d0e21e 1447 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1448 register PERL_CONTEXT *cx;
2c375eb9 1449 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1450 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1451 I32 dbcxix;
54310121 1452 I32 gimme;
ed094faf 1453 char *stashname;
a0d0e21e
LW		 1454 SV *sv;
1455 I32 count = 0;
1456
1457 if (MAXARG)
1458 count = POPi;
f3aa04c2 1459 EXTEND(SP, 7);
a0d0e21e 1460 for (;;) {
2c375eb9
GS		 1461 /* we may be in a higher stacklevel, so dig down deeper */
1462 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1463 top_si = top_si->si_prev;
1464 ccstack = top_si->si_cxstack;
1465 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1466 }
a0d0e21e
LW		 1467 if (cxix < 0) {
1468 if (GIMME != G_ARRAY)
1469 RETPUSHUNDEF;
1470 RETURN;
1471 }
3280af22
NIS		 1472 if (PL_DBsub && cxix >= 0 &&
1473 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1474 count++;
1475 if (!count--)
1476 break;
2c375eb9 1477 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1478 }
2c375eb9
GS		 1479
1480 cx = &ccstack[cxix];
7766f137 1481 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2c375eb9
GS		 1482 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1483 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1484 field below is defined for any cx. */
3280af22 1485 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1486 cx = &ccstack[dbcxix];
06a5b730 1487 }
1488
ed094faf 1489 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1490 if (GIMME != G_ARRAY) {
ed094faf 1491 if (!stashname)
3280af22 1492 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1493 else {
1494 dTARGET;
ed094faf 1495 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1496 PUSHs(TARG);
1497 }
a0d0e21e
LW		 1498 RETURN;
1499 }
a0d0e21e 1500
ed094faf 1501 if (!stashname)
3280af22 1502 PUSHs(&PL_sv_undef);
49d8d3a1 1503 else
ed094faf
GS		 1504 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1505 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
57843af0 1506 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1507 if (!MAXARG)
1508 RETURN;
7766f137
GS		 1509 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1510 /* So is ccstack[dbcxix]. */
a0d0e21e 1511 sv = NEWSV(49, 0);
2c375eb9 1512 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW		 1513 PUSHs(sv_2mortal(sv));
1514 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1515 }
1516 else {
79cb57f6 1517 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1518 PUSHs(sv_2mortal(newSViv(0)));
1519 }
54310121 1520 gimme = (I32)cx->blk_gimme;
1521 if (gimme == G_VOID)
3280af22 1522 PUSHs(&PL_sv_undef);
54310121 1523 else
1524 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1525 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1526 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1527 PUSHs(cx->blk_eval.cur_text);
3280af22 1528 PUSHs(&PL_sv_no);
06a5b730 1529 }
1530 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1531 /* Require, put the name. */
1532 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1533 PUSHs(&PL_sv_yes);
06a5b730 1534 }
4633a7c4 1535 }
a682de96
GS		 1536 else {
1537 PUSHs(&PL_sv_undef);
1538 PUSHs(&PL_sv_undef);
1539 }
1540 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1541 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1542 {
a0d0e21e
LW		 1543 AV *ary = cx->blk_sub.argarray;
1544 int off = AvARRAY(ary) - AvALLOC(ary);
1545
3280af22 1546 if (!PL_dbargs) {
a0d0e21e 1547 GV* tmpgv;
3280af22 1548 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1549 SVt_PVAV)));
a5f75d66 1550 GvMULTI_on(tmpgv);
3280af22 1551 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW		 1552 }
1553
3280af22
NIS		 1554 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1555 av_extend(PL_dbargs, AvFILLp(ary) + off);
1556 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1557 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1558 }
f3aa04c2
GS		 1559 /* XXX only hints propagated via op_private are currently
1560 * visible (others are not easily accessible, since they
1561 * use the global PL_hints) */
1562 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1563 HINT_PRIVATE_MASK)));
a0d0e21e
LW		 1564 RETURN;
1565}
1566
a0d0e21e
LW		 1567PP(pp_reset)
1568{
4e35701f 1569 djSP;
a0d0e21e 1570 char *tmps;
2d8e6c8d 1571 STRLEN n_a;
a0d0e21e
LW		 1572
1573 if (MAXARG < 1)
1574 tmps = "";
1575 else
2d8e6c8d 1576 tmps = POPpx;
11faa288 1577 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1578 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1579 RETURN;
1580}
1581
1582PP(pp_lineseq)
1583{
1584 return NORMAL;
1585}
1586
1587PP(pp_dbstate)
1588{
533c011a 1589 PL_curcop = (COP*)PL_op;
a0d0e21e 1590 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1591 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1592 FREETMPS;
1593
533c011a 1594 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1595 {
924508f0 1596 djSP;
a0d0e21e 1597 register CV *cv;
c09156bb 1598 register PERL_CONTEXT *cx;
748a9306 1599 I32 gimme = G_ARRAY;
a0d0e21e
LW		 1600 I32 hasargs;
1601 GV *gv;
1602
3280af22 1603 gv = PL_DBgv;
a0d0e21e 1604 cv = GvCV(gv);
a0d0e21e 1605 if (!cv)
cea2e8a9 1606 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1607
3280af22 1608 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1609 return NORMAL;
748a9306 1610
4633a7c4
LW		 1611 ENTER;
1612 SAVETMPS;
1613
3280af22 1614 SAVEI32(PL_debug);
55497cff 1615 SAVESTACK_POS();
3280af22 1616 PL_debug = 0;
748a9306 1617 hasargs = 0;
924508f0 1618 SPAGAIN;
748a9306 1619
533c011a 1620 push_return(PL_op->op_next);
924508f0 1621 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW		 1622 PUSHSUB(cx);
1623 CvDEPTH(cv)++;
1624 (void)SvREFCNT_inc(cv);
7766f137 1625 SAVEVPTR(PL_curpad);
3280af22 1626 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW		 1627 RETURNOP(CvSTART(cv));
1628 }
1629 else
1630 return NORMAL;
1631}
1632
1633PP(pp_scope)
1634{
1635 return NORMAL;
1636}
1637
1638PP(pp_enteriter)
1639{
4e35701f 1640 djSP; dMARK;
c09156bb 1641 register PERL_CONTEXT *cx;
54310121 1642 I32 gimme = GIMME_V;
a0d0e21e 1643 SV **svp;
7766f137
GS		 1644 U32 cxtype = CXt_LOOP;
1645#ifdef USE_ITHREADS
1646 void *iterdata;
1647#endif
a0d0e21e 1648
4633a7c4
LW		 1649 ENTER;
1650 SAVETMPS;
1651
54b9620d 1652#ifdef USE_THREADS
0214ae40
GS		 1653 if (PL_op->op_flags & OPf_SPECIAL) {
1654 dTHR;
1655 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1656 SAVEGENERICSV(*svp);
1657 *svp = NEWSV(0,0);
1658 }
a0d0e21e 1659 else
54b9620d 1660#endif /* USE_THREADS */
533c011a
NIS		 1661 if (PL_op->op_targ) {
1662 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d 1663 SAVESPTR(*svp);
7766f137
GS		 1664#ifdef USE_ITHREADS
1665 iterdata = (void*)PL_op->op_targ;
1666 cxtype |= CXp_PADVAR;
1667#endif
54b9620d
MB		 1668 }
1669 else {
7766f137
GS		 1670 GV *gv = (GV*)POPs;
1671 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1672 SAVEGENERICSV(*svp);
1673 *svp = NEWSV(0,0);
7766f137
GS		 1674#ifdef USE_ITHREADS
1675 iterdata = (void*)gv;
1676#endif
54b9620d 1677 }
4633a7c4 1678
a0d0e21e
LW		 1679 ENTER;
1680
7766f137
GS		 1681 PUSHBLOCK(cx, cxtype, SP);
1682#ifdef USE_ITHREADS
1683 PUSHLOOP(cx, iterdata, MARK);
1684#else
a0d0e21e 1685 PUSHLOOP(cx, svp, MARK);
7766f137 1686#endif
533c011a 1687 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1688 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1689 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1690 dPOPss;
1691 if (SvNIOKp(sv) || !SvPOKp(sv) ||
39eb4040
GS		 1692 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1693 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1694 looks_like_number((SV*)cx->blk_loop.iterary) &&
1695 *SvPVX(cx->blk_loop.iterary) != '0'))
1696 {
89ea2908
GA		 1697 if (SvNV(sv) < IV_MIN ||
1698 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
d470f89e 1699 DIE(aTHX_ "Range iterator outside integer range");
89ea2908
GA		 1700 cx->blk_loop.iterix = SvIV(sv);
1701 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1702 }
1703 else
1704 cx->blk_loop.iterlval = newSVsv(sv);
1705 }
1706 }
4633a7c4 1707 else {
3280af22
NIS		 1708 cx->blk_loop.iterary = PL_curstack;
1709 AvFILLp(PL_curstack) = SP - PL_stack_base;
1710 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1711 }
a0d0e21e
LW		 1712
1713 RETURN;
1714}
1715
1716PP(pp_enterloop)
1717{
4e35701f 1718 djSP;
c09156bb 1719 register PERL_CONTEXT *cx;
54310121 1720 I32 gimme = GIMME_V;
a0d0e21e
LW		 1721
1722 ENTER;
1723 SAVETMPS;
1724 ENTER;
1725
1726 PUSHBLOCK(cx, CXt_LOOP, SP);
1727 PUSHLOOP(cx, 0, SP);
1728
1729 RETURN;
1730}
1731
1732PP(pp_leaveloop)
1733{
4e35701f 1734 djSP;
c09156bb 1735 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1736 I32 gimme;
1737 SV **newsp;
1738 PMOP *newpm;
1739 SV **mark;
1740
1741 POPBLOCK(cx,newpm);
4fdae800 1742 mark = newsp;
a8bba7fa 1743 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1744
a1f49e72 1745 TAINT_NOT;
54310121 1746 if (gimme == G_VOID)
1747 ; /* do nothing */
1748 else if (gimme == G_SCALAR) {
1749 if (mark < SP)
1750 *++newsp = sv_mortalcopy(*SP);
1751 else
3280af22 1752 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1753 }
1754 else {
a1f49e72 1755 while (mark < SP) {
a0d0e21e 1756 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1757 TAINT_NOT; /* Each item is independent */
1758 }
a0d0e21e 1759 }
f86702cc 1760 SP = newsp;
1761 PUTBACK;
1762
a8bba7fa 1763 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1764 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1765
a0d0e21e
LW		 1766 LEAVE;
1767 LEAVE;
1768
f86702cc 1769 return NORMAL;
a0d0e21e
LW		 1770}
1771
1772PP(pp_return)
1773{
4e35701f 1774 djSP; dMARK;
a0d0e21e 1775 I32 cxix;
c09156bb 1776 register PERL_CONTEXT *cx;
f86702cc 1777 bool popsub2 = FALSE;
a0d0e21e
LW		 1778 I32 gimme;
1779 SV **newsp;
1780 PMOP *newpm;
1781 I32 optype = 0;
b0d9ce38 1782 SV *sv;
a0d0e21e 1783
3280af22 1784 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS		 1785 if (cxstack_ix == PL_sortcxix
1786 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1787 {
3280af22
NIS		 1788 if (cxstack_ix > PL_sortcxix)
1789 dounwind(PL_sortcxix);
1790 AvARRAY(PL_curstack)[1] = *SP;
1791 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1792 return 0;
1793 }
1794 }
1795
1796 cxix = dopoptosub(cxstack_ix);
1797 if (cxix < 0)
cea2e8a9 1798 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1799 if (cxix < cxstack_ix)
1800 dounwind(cxix);
1801
1802 POPBLOCK(cx,newpm);
6b35e009 1803 switch (CxTYPE(cx)) {
a0d0e21e 1804 case CXt_SUB:
f86702cc 1805 popsub2 = TRUE;
a0d0e21e
LW		 1806 break;
1807 case CXt_EVAL:
1808 POPEVAL(cx);
067f92a0
GS		 1809 if (AvFILLp(PL_comppad_name) >= 0)
1810 free_closures();
1811 lex_end();
748a9306
LW		 1812 if (optype == OP_REQUIRE &&
1813 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1814 {
54310121 1815 /* Unassume the success we assumed earlier. */
748a9306 1816 char *name = cx->blk_eval.old_name;
3280af22 1817 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 1818 DIE(aTHX_ "%s did not return a true value", name);
748a9306 1819 }
a0d0e21e 1820 break;
7766f137
GS		 1821 case CXt_FORMAT:
1822 POPFORMAT(cx);
1823 break;
a0d0e21e 1824 default:
cea2e8a9 1825 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1826 }
1827
a1f49e72 1828 TAINT_NOT;
a0d0e21e 1829 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1830 if (MARK < SP) {
1831 if (popsub2) {
a8bba7fa 1832 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 1833 if (SvTEMP(TOPs)) {
1834 *++newsp = SvREFCNT_inc(*SP);
1835 FREETMPS;
1836 sv_2mortal(*newsp);
1837 } else {
1838 FREETMPS;
1839 *++newsp = sv_mortalcopy(*SP);
1840 }
1841 } else
1842 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1843 } else
1844 *++newsp = sv_mortalcopy(*SP);
1845 } else
3280af22 1846 *++newsp = &PL_sv_undef;
a0d0e21e 1847 }
54310121 1848 else if (gimme == G_ARRAY) {
a1f49e72 1849 while (++MARK <= SP) {
f86702cc 1850 *++newsp = (popsub2 && SvTEMP(*MARK))
1851 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1852 TAINT_NOT; /* Each item is independent */
1853 }
a0d0e21e 1854 }
3280af22 1855 PL_stack_sp = newsp;
a0d0e21e 1856
f86702cc 1857 /* Stack values are safe: */
1858 if (popsub2) {
b0d9ce38 1859 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1860 }
b0d9ce38
GS		 1861 else
1862 sv = Nullsv;
3280af22 1863 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1864
a0d0e21e 1865 LEAVE;
b0d9ce38 1866 LEAVESUB(sv);
a0d0e21e
LW		 1867 return pop_return();
1868}
1869
1870PP(pp_last)
1871{
4e35701f 1872 djSP;
a0d0e21e 1873 I32 cxix;
c09156bb 1874 register PERL_CONTEXT *cx;
f86702cc 1875 I32 pop2 = 0;
a0d0e21e
LW		 1876 I32 gimme;
1877 I32 optype;
1878 OP *nextop;
1879 SV **newsp;
1880 PMOP *newpm;
a8bba7fa 1881 SV **mark;
b0d9ce38 1882 SV *sv = Nullsv;
a0d0e21e 1883
533c011a 1884 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1885 cxix = dopoptoloop(cxstack_ix);
1886 if (cxix < 0)
a651a37d 1887 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 1888 }
1889 else {
1890 cxix = dopoptolabel(cPVOP->op_pv);
1891 if (cxix < 0)
cea2e8a9 1892 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1893 }
1894 if (cxix < cxstack_ix)
1895 dounwind(cxix);
1896
1897 POPBLOCK(cx,newpm);
a8bba7fa 1898 mark = newsp;
6b35e009 1899 switch (CxTYPE(cx)) {
a0d0e21e 1900 case CXt_LOOP:
f86702cc 1901 pop2 = CXt_LOOP;
a8bba7fa
GS		 1902 newsp = PL_stack_base + cx->blk_loop.resetsp;
1903 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1904 break;
f86702cc 1905 case CXt_SUB:
f86702cc 1906 pop2 = CXt_SUB;
a0d0e21e
LW		 1907 nextop = pop_return();
1908 break;
f86702cc 1909 case CXt_EVAL:
1910 POPEVAL(cx);
a0d0e21e
LW		 1911 nextop = pop_return();
1912 break;
7766f137
GS		 1913 case CXt_FORMAT:
1914 POPFORMAT(cx);
1915 nextop = pop_return();
1916 break;
a0d0e21e 1917 default:
cea2e8a9 1918 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 1919 }
1920
a1f49e72 1921 TAINT_NOT;
a0d0e21e 1922 if (gimme == G_SCALAR) {
f86702cc 1923 if (MARK < SP)
1924 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1925 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1926 else
3280af22 1927 *++newsp = &PL_sv_undef;
a0d0e21e 1928 }
54310121 1929 else if (gimme == G_ARRAY) {
a1f49e72 1930 while (++MARK <= SP) {
f86702cc 1931 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1932 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1933 TAINT_NOT; /* Each item is independent */
1934 }
f86702cc 1935 }
1936 SP = newsp;
1937 PUTBACK;
1938
1939 /* Stack values are safe: */
1940 switch (pop2) {
1941 case CXt_LOOP:
a8bba7fa 1942 POPLOOP(cx); /* release loop vars ... */
4fdae800 1943 LEAVE;
f86702cc 1944 break;
1945 case CXt_SUB:
b0d9ce38 1946 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1947 break;
a0d0e21e 1948 }
3280af22 1949 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1950
1951 LEAVE;
b0d9ce38 1952 LEAVESUB(sv);
f86702cc 1953 return nextop;
a0d0e21e
LW		 1954}
1955
1956PP(pp_next)
1957{
1958 I32 cxix;
c09156bb 1959 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1960 I32 oldsave;
1961
533c011a 1962 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1963 cxix = dopoptoloop(cxstack_ix);
1964 if (cxix < 0)
a651a37d 1965 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 1966 }
1967 else {
1968 cxix = dopoptolabel(cPVOP->op_pv);
1969 if (cxix < 0)
cea2e8a9 1970 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1971 }
1972 if (cxix < cxstack_ix)
1973 dounwind(cxix);
1974
87246558 1975 cx = &cxstack[cxstack_ix];
1ee98724
GS		 1976 {
1977 OP *nextop = cx->blk_loop.next_op;
1978 /* clean scope, but only if there's no continue block */
1979 if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) {
87246558 1980 TOPBLOCK(cx);
1ee98724
GS		 1981 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1982 LEAVE_SCOPE(oldsave);
1983 }
1984 return nextop;
1985 }
a0d0e21e
LW		 1986}
1987
1988PP(pp_redo)
1989{
1990 I32 cxix;
c09156bb 1991 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1992 I32 oldsave;
1993
533c011a 1994 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1995 cxix = dopoptoloop(cxstack_ix);
1996 if (cxix < 0)
a651a37d 1997 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 1998 }
1999 else {
2000 cxix = dopoptolabel(cPVOP->op_pv);
2001 if (cxix < 0)
cea2e8a9 2002 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2003 }
2004 if (cxix < cxstack_ix)
2005 dounwind(cxix);
2006
2007 TOPBLOCK(cx);
3280af22 2008 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2009 LEAVE_SCOPE(oldsave);
2010 return cx->blk_loop.redo_op;
2011}
2012
0824fdcb 2013STATIC OP *
cea2e8a9 2014S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 2015{
2016 OP *kid;
2017 OP **ops = opstack;
fc36a67e 2018 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2019
fc36a67e 2020 if (ops >= oplimit)
cea2e8a9 2021 Perl_croak(aTHX_ too_deep);
11343788
MB		 2022 if (o->op_type == OP_LEAVE ||
2023 o->op_type == OP_SCOPE ||
2024 o->op_type == OP_LEAVELOOP ||
2025 o->op_type == OP_LEAVETRY)
fc36a67e 2026 {
5dc0d613 2027 *ops++ = cUNOPo->op_first;
fc36a67e 2028 if (ops >= oplimit)
cea2e8a9 2029 Perl_croak(aTHX_ too_deep);
fc36a67e 2030 }
c4aa4e48 2031 *ops = 0;
11343788 2032 if (o->op_flags & OPf_KIDS) {
5c0ca799 2033 dTHR;
a0d0e21e 2034 /* First try all the kids at this level, since that's likeliest. */
11343788 2035 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2036 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2037 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2038 return kid;
2039 }
11343788 2040 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2041 if (kid == PL_lastgotoprobe)
a0d0e21e 2042 continue;
c4aa4e48
GS		 2043 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2044 (ops == opstack ||
2045 (ops[-1]->op_type != OP_NEXTSTATE &&
2046 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 2047 *ops++ = kid;
5dc0d613 2048 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 2049 return o;
a0d0e21e
LW		 2050 }
2051 }
c4aa4e48 2052 *ops = 0;
a0d0e21e
LW		 2053 return 0;
2054}
2055
2056PP(pp_dump)
2057{
cea2e8a9 2058 return pp_goto();
a0d0e21e
LW		 2059 /*NOTREACHED*/
2060}
2061
2062PP(pp_goto)
2063{
4e35701f 2064 djSP;
a0d0e21e
LW		 2065 OP *retop = 0;
2066 I32 ix;
c09156bb 2067 register PERL_CONTEXT *cx;
fc36a67e 2068#define GOTO_DEPTH 64
2069 OP *enterops[GOTO_DEPTH];
a0d0e21e 2070 char *label;
533c011a 2071 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2072 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 2073
2074 label = 0;
533c011a 2075 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2076 SV *sv = POPs;
2d8e6c8d 2077 STRLEN n_a;
a0d0e21e
LW		 2078
2079 /* This egregious kludge implements goto &subroutine */
2080 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2081 I32 cxix;
c09156bb 2082 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2083 CV* cv = (CV*)SvRV(sv);
2084 SV** mark;
2085 I32 items = 0;
2086 I32 oldsave;
2087
e8f7dd13 2088 retry:
4aa0a1f7 2089 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 2090 GV *gv = CvGV(cv);
2091 GV *autogv;
2092 if (gv) {
2093 SV *tmpstr;
2094 /* autoloaded stub? */
2095 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2096 goto retry;
2097 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2098 GvNAMELEN(gv), FALSE);
2099 if (autogv && (cv = GvCV(autogv)))
2100 goto retry;
2101 tmpstr = sv_newmortal();
2102 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2103 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2104 }
cea2e8a9 2105 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2106 }
2107
a0d0e21e
LW		 2108 /* First do some returnish stuff. */
2109 cxix = dopoptosub(cxstack_ix);
2110 if (cxix < 0)
cea2e8a9 2111 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2112 if (cxix < cxstack_ix)
2113 dounwind(cxix);
2114 TOPBLOCK(cx);
6b35e009 2115 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2116 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2117 mark = PL_stack_sp;
d8b46c1b
GS		 2118 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2119 /* put @_ back onto stack */
a0d0e21e
LW		 2120 AV* av = cx->blk_sub.argarray;
2121
93965878 2122 items = AvFILLp(av) + 1;
3280af22
NIS		 2123 PL_stack_sp++;
2124 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2125 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2126 PL_stack_sp += items;
6d4ff0d2 2127#ifndef USE_THREADS
3280af22
NIS		 2128 SvREFCNT_dec(GvAV(PL_defgv));
2129 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2130#endif /* USE_THREADS */
d8b46c1b 2131 /* abandon @_ if it got reified */
62b1ebc2 2132 if (AvREAL(av)) {
d8b46c1b
GS		 2133 (void)sv_2mortal((SV*)av); /* delay until return */
2134 av = newAV();
2135 av_extend(av, items-1);
2136 AvFLAGS(av) = AVf_REIFY;
2137 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2138 }
a0d0e21e 2139 }
1fa4e549
AD		 2140 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2141 AV* av;
2142 int i;
2143#ifdef USE_THREADS
533c011a 2144 av = (AV*)PL_curpad[0];
1fa4e549 2145#else
3280af22 2146 av = GvAV(PL_defgv);
1fa4e549
AD		 2147#endif
2148 items = AvFILLp(av) + 1;
3280af22
NIS		 2149 PL_stack_sp++;
2150 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2151 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2152 PL_stack_sp += items;
1fa4e549 2153 }
6b35e009 2154 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2155 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2156 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2157 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2158 LEAVE_SCOPE(oldsave);
2159
2160 /* Now do some callish stuff. */
2161 SAVETMPS;
2162 if (CvXSUB(cv)) {
67caa1fe 2163#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2164 if (CvOLDSTYLE(cv)) {
20ce7b12 2165 I32 (*fp3)(int,int,int);
924508f0
GS		 2166 while (SP > mark) {
2167 SP[1] = SP[0];
2168 SP--;
a0d0e21e 2169 }
7766f137 2170 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2171 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2172 mark - PL_stack_base + 1,
ecfc5424 2173 items);
3280af22 2174 SP = PL_stack_base + items;
a0d0e21e 2175 }
67caa1fe
GS		 2176 else
2177#endif /* PERL_XSUB_OLDSTYLE */
2178 {
1fa4e549
AD		 2179 SV **newsp;
2180 I32 gimme;
2181
3280af22 2182 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 2183 /* Push a mark for the start of arglist */
2184 PUSHMARK(mark);
0cb96387 2185 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2186 /* Pop the current context like a decent sub should */
3280af22 2187 POPBLOCK(cx, PL_curpm);
1fa4e549 2188 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2189 }
2190 LEAVE;
2191 return pop_return();
2192 }
2193 else {
2194 AV* padlist = CvPADLIST(cv);
2195 SV** svp = AvARRAY(padlist);
6b35e009 2196 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2197 PL_in_eval = cx->blk_eval.old_in_eval;
2198 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2199 cx->cx_type = CXt_SUB;
2200 cx->blk_sub.hasargs = 0;
2201 }
a0d0e21e
LW		 2202 cx->blk_sub.cv = cv;
2203 cx->blk_sub.olddepth = CvDEPTH(cv);
2204 CvDEPTH(cv)++;
2205 if (CvDEPTH(cv) < 2)
2206 (void)SvREFCNT_inc(cv);
2207 else { /* save temporaries on recursion? */
599cee73 2208 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2209 sub_crush_depth(cv);
93965878 2210 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2211 AV *newpad = newAV();
4aa0a1f7 2212 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2213 I32 ix = AvFILLp((AV*)svp[1]);
7766f137 2214 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2215 svp = AvARRAY(svp[0]);
748a9306 2216 for ( ;ix > 0; ix--) {
7766f137 2217 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2218 char *name = SvPVX(svp[ix]);
5f05dabc 2219 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2220 || *name == '&')
2221 {
2222 /* outer lexical or anon code */
748a9306 2223 av_store(newpad, ix,
4aa0a1f7 2224 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 2225 }
2226 else { /* our own lexical */
2227 if (*name == '@')
2228 av_store(newpad, ix, sv = (SV*)newAV());
2229 else if (*name == '%')
2230 av_store(newpad, ix, sv = (SV*)newHV());
2231 else
2232 av_store(newpad, ix, sv = NEWSV(0,0));
2233 SvPADMY_on(sv);
2234 }
a0d0e21e 2235 }
7766f137 2236 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
743e66e6
GS		 2237 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2238 }
a0d0e21e 2239 else {
748a9306 2240 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 2241 SvPADTMP_on(sv);
2242 }
2243 }
2244 if (cx->blk_sub.hasargs) {
2245 AV* av = newAV();
2246 av_extend(av, 0);
2247 av_store(newpad, 0, (SV*)av);
2248 AvFLAGS(av) = AVf_REIFY;
2249 }
2250 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2251 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2252 svp = AvARRAY(padlist);
2253 }
2254 }
6d4ff0d2
MB		 2255#ifdef USE_THREADS
2256 if (!cx->blk_sub.hasargs) {
533c011a 2257 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2258
93965878 2259 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2260 if (items) {
2261 /* Mark is at the end of the stack. */
924508f0
GS		 2262 EXTEND(SP, items);
2263 Copy(AvARRAY(av), SP + 1, items, SV*);
2264 SP += items;
6d4ff0d2
MB		 2265 PUTBACK ;
2266 }
2267 }
2268#endif /* USE_THREADS */
7766f137 2269 SAVEVPTR(PL_curpad);
3280af22 2270 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2271#ifndef USE_THREADS
2272 if (cx->blk_sub.hasargs)
2273#endif /* USE_THREADS */
2274 {
3280af22 2275 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2276 SV** ary;
2277
6d4ff0d2 2278#ifndef USE_THREADS
3280af22
NIS		 2279 cx->blk_sub.savearray = GvAV(PL_defgv);
2280 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2281#endif /* USE_THREADS */
2282 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2283 ++mark;
2284
2285 if (items >= AvMAX(av) + 1) {
2286 ary = AvALLOC(av);
2287 if (AvARRAY(av) != ary) {
2288 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2289 SvPVX(av) = (char*)ary;
2290 }
2291 if (items >= AvMAX(av) + 1) {
2292 AvMAX(av) = items - 1;
2293 Renew(ary,items+1,SV*);
2294 AvALLOC(av) = ary;
2295 SvPVX(av) = (char*)ary;
2296 }
2297 }
2298 Copy(mark,AvARRAY(av),items,SV*);
93965878 2299 AvFILLp(av) = items - 1;
d8b46c1b 2300 assert(!AvREAL(av));
a0d0e21e
LW		 2301 while (items--) {
2302 if (*mark)
2303 SvTEMP_off(*mark);
2304 mark++;
2305 }
2306 }
491527d0 2307 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2308 /*
2309 * We do not care about using sv to call CV;
2310 * it's for informational purposes only.
2311 */
3280af22 2312 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2313 CV *gotocv;
2314
2315 if (PERLDB_SUB_NN) {
56431972 2316 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS		 2317 } else {
2318 save_item(sv);
2319 gv_efullname3(sv, CvGV(cv), Nullch);
2320 }
2321 if ( PERLDB_GOTO
864dbfa3 2322 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2323 PUSHMARK( PL_stack_sp );
864dbfa3 2324 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2325 PL_stack_sp--;
491527d0 2326 }
1ce6579f 2327 }
a0d0e21e
LW		 2328 RETURNOP(CvSTART(cv));
2329 }
2330 }
1614b0e3 2331 else {
2d8e6c8d 2332 label = SvPV(sv,n_a);
1614b0e3 2333 if (!(do_dump || *label))
cea2e8a9 2334 DIE(aTHX_ must_have_label);
1614b0e3 2335 }
a0d0e21e 2336 }
533c011a 2337 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2338 if (! do_dump)
cea2e8a9 2339 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2340 }
2341 else
2342 label = cPVOP->op_pv;
2343
2344 if (label && *label) {
2345 OP *gotoprobe = 0;
2346
2347 /* find label */
2348
3280af22 2349 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2350 *enterops = 0;
2351 for (ix = cxstack_ix; ix >= 0; ix--) {
2352 cx = &cxstack[ix];
6b35e009 2353 switch (CxTYPE(cx)) {
a0d0e21e 2354 case CXt_EVAL:
3280af22 2355 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2356 break;
2357 case CXt_LOOP:
2358 gotoprobe = cx->blk_oldcop->op_sibling;
2359 break;
2360 case CXt_SUBST:
2361 continue;
2362 case CXt_BLOCK:
2363 if (ix)
2364 gotoprobe = cx->blk_oldcop->op_sibling;
2365 else
3280af22 2366 gotoprobe = PL_main_root;
a0d0e21e 2367 break;
b3933176
CS		 2368 case CXt_SUB:
2369 if (CvDEPTH(cx->blk_sub.cv)) {
2370 gotoprobe = CvROOT(cx->blk_sub.cv);
2371 break;
2372 }
2373 /* FALL THROUGH */
7766f137 2374 case CXt_FORMAT:
0a753a76 2375 case CXt_NULL:
a651a37d 2376 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2377 default:
2378 if (ix)
cea2e8a9 2379 DIE(aTHX_ "panic: goto");
3280af22 2380 gotoprobe = PL_main_root;
a0d0e21e
LW		 2381 break;
2382 }
fc36a67e 2383 retop = dofindlabel(gotoprobe, label,
2384 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW		 2385 if (retop)
2386 break;
3280af22 2387 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2388 }
2389 if (!retop)
cea2e8a9 2390 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW		 2391
2392 /* pop unwanted frames */
2393
2394 if (ix < cxstack_ix) {
2395 I32 oldsave;
2396
2397 if (ix < 0)
2398 ix = 0;
2399 dounwind(ix);
2400 TOPBLOCK(cx);
3280af22 2401 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2402 LEAVE_SCOPE(oldsave);
2403 }
2404
2405 /* push wanted frames */
2406
748a9306 2407 if (*enterops && enterops[1]) {
533c011a 2408 OP *oldop = PL_op;
748a9306 2409 for (ix = 1; enterops[ix]; ix++) {
533c011a 2410 PL_op = enterops[ix];
84902520
TB		 2411 /* Eventually we may want to stack the needed arguments
2412 * for each op. For now, we punt on the hard ones. */
533c011a 2413 if (PL_op->op_type == OP_ENTERITER)
894356b3 2414 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2415 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2416 }
533c011a 2417 PL_op = oldop;
a0d0e21e
LW		 2418 }
2419 }
2420
2421 if (do_dump) {
a5f75d66 2422#ifdef VMS
6b88bc9c 2423 if (!retop) retop = PL_main_start;
a5f75d66 2424#endif
3280af22
NIS		 2425 PL_restartop = retop;
2426 PL_do_undump = TRUE;
a0d0e21e
LW		 2427
2428 my_unexec();
2429
3280af22
NIS		 2430 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2431 PL_do_undump = FALSE;
a0d0e21e
LW		 2432 }
2433
2434 RETURNOP(retop);
2435}
2436
2437PP(pp_exit)
2438{
4e35701f 2439 djSP;
a0d0e21e
LW		 2440 I32 anum;
2441
2442 if (MAXARG < 1)
2443 anum = 0;
ff0cee69 2444 else {
a0d0e21e 2445 anum = SvIVx(POPs);
ff0cee69 2446#ifdef VMSISH_EXIT
2447 if (anum == 1 && VMSISH_EXIT)
2448 anum = 0;
2449#endif
2450 }
cc3604b1 2451 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2452 my_exit(anum);
3280af22 2453 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2454 RETURN;
2455}
2456
2457#ifdef NOTYET
2458PP(pp_nswitch)
2459{
4e35701f 2460 djSP;
65202027 2461 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2462 register I32 match = I_32(value);
2463
2464 if (value < 0.0) {
65202027 2465 if (((NV)match) > value)
a0d0e21e
LW		 2466 --match; /* was fractional--truncate other way */
2467 }
2468 match -= cCOP->uop.scop.scop_offset;
2469 if (match < 0)
2470 match = 0;
2471 else if (match > cCOP->uop.scop.scop_max)
2472 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2473 PL_op = cCOP->uop.scop.scop_next[match];
2474 RETURNOP(PL_op);
a0d0e21e
LW		 2475}
2476
2477PP(pp_cswitch)
2478{
4e35701f 2479 djSP;
a0d0e21e
LW		 2480 register I32 match;
2481
6b88bc9c
GS		 2482 if (PL_multiline)
2483 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2484 else {
2d8e6c8d
GS		 2485 STRLEN n_a;
2486 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2487 match -= cCOP->uop.scop.scop_offset;
2488 if (match < 0)
2489 match = 0;
2490 else if (match > cCOP->uop.scop.scop_max)
2491 match = cCOP->uop.scop.scop_max;
6b88bc9c 2492 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2493 }
6b88bc9c 2494 RETURNOP(PL_op);
a0d0e21e
LW		 2495}
2496#endif
2497
2498/* Eval. */
2499
0824fdcb 2500STATIC void
cea2e8a9 2501S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2502{
2503 register char *s = SvPVX(sv);
2504 register char *send = SvPVX(sv) + SvCUR(sv);
2505 register char *t;
2506 register I32 line = 1;
2507
2508 while (s && s < send) {
2509 SV *tmpstr = NEWSV(85,0);
2510
2511 sv_upgrade(tmpstr, SVt_PVMG);
2512 t = strchr(s, '\n');
2513 if (t)
2514 t++;
2515 else
2516 t = send;
2517
2518 sv_setpvn(tmpstr, s, t - s);
2519 av_store(array, line++, tmpstr);
2520 s = t;
2521 }
2522}
2523
312caa8e 2524STATIC void *
cea2e8a9 2525S_docatch_body(pTHX_ va_list args)
312caa8e 2526{
cea2e8a9 2527 CALLRUNOPS(aTHX);
312caa8e
CS		 2528 return NULL;
2529}
2530
0824fdcb 2531STATIC OP *
cea2e8a9 2532S_docatch(pTHX_ OP *o)
1e422769 2533{
e858de61 2534 dTHR;
6224f72b 2535 int ret;
533c011a 2536 OP *oldop = PL_op;
0cdb2077 2537 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2538 dJMPENV;
1e422769 2539
1e422769 2540#ifdef DEBUGGING
54310121 2541 assert(CATCH_GET == TRUE);
1e422769 2542#endif
312caa8e
CS		 2543 PL_op = o;
2544 redo_body:
db36c5a1 2545 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
6224f72b 2546 switch (ret) {
312caa8e
CS		 2547 case 0:
2548 break;
2549 case 3:
0cdb2077 2550 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2551 PL_op = PL_restartop;
2552 PL_restartop = 0;
2553 goto redo_body;
2554 }
2555 /* FALL THROUGH */
2556 default:
533c011a 2557 PL_op = oldop;
6224f72b 2558 JMPENV_JUMP(ret);
1e422769 2559 /* NOTREACHED */
1e422769 2560 }
533c011a 2561 PL_op = oldop;
1e422769 2562 return Nullop;
2563}
2564
c277df42 2565OP *
864dbfa3 2566Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ		 2567/* sv Text to convert to OP tree. */
2568/* startop op_free() this to undo. */
2569/* code Short string id of the caller. */
2570{
2571 dSP; /* Make POPBLOCK work. */
2572 PERL_CONTEXT *cx;
2573 SV **newsp;
f987c7de 2574 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2575 I32 optype;
2576 OP dummy;
533c011a 2577 OP *oop = PL_op, *rop;
83ee9e09
GS		 2578 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2579 char *tmpbuf = tbuf;
c277df42
IZ		 2580 char *safestr;
2581
2582 ENTER;
2583 lex_start(sv);
2584 SAVETMPS;
2585 /* switch to eval mode */
2586
cbce877f 2587 if (PL_curcop == &PL_compiling) {
11faa288
GS		 2588 SAVECOPSTASH(&PL_compiling);
2589 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2590 }
57843af0
GS		 2591 SAVECOPFILE(&PL_compiling);
2592 SAVECOPLINE(&PL_compiling);
83ee9e09
GS		 2593 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2594 SV *sv = sv_newmortal();
2595 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2596 code, (unsigned long)++PL_evalseq,
2597 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2598 tmpbuf = SvPVX(sv);
2599 }
2600 else
2601 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
57843af0
GS		 2602 CopFILE_set(&PL_compiling, tmpbuf+2);
2603 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2604 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2605 deleting the eval's FILEGV from the stash before gv_check() runs
2606 (i.e. before run-time proper). To work around the coredump that
2607 ensues, we always turn GvMULTI_on for any globals that were
2608 introduced within evals. See force_ident(). GSAR 96-10-12 */
2609 safestr = savepv(tmpbuf);
3280af22 2610 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2611 SAVEHINTS();
d1ca3daa 2612#ifdef OP_IN_REGISTER
6b88bc9c 2613 PL_opsave = op;
d1ca3daa 2614#else
7766f137 2615 SAVEVPTR(PL_op);
d1ca3daa 2616#endif
3280af22 2617 PL_hints = 0;
c277df42 2618
533c011a 2619 PL_op = &dummy;
13b51b79 2620 PL_op->op_type = OP_ENTEREVAL;
533c011a 2621 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2622 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2623 PUSHEVAL(cx, 0, Nullgv);
c277df42 2624 rop = doeval(G_SCALAR, startop);
13b51b79 2625 POPBLOCK(cx,PL_curpm);
e84b9f1f 2626 POPEVAL(cx);
c277df42
IZ		 2627
2628 (*startop)->op_type = OP_NULL;
22c35a8c 2629 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2630 lex_end();
3280af22 2631 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2632 LEAVE;
13b51b79 2633 if (PL_curcop == &PL_compiling)
a0ed51b3 2634 PL_compiling.op_private = PL_hints;
d1ca3daa 2635#ifdef OP_IN_REGISTER
6b88bc9c 2636 op = PL_opsave;
d1ca3daa 2637#endif
c277df42
IZ		 2638 return rop;
2639}
2640
0f15f207 2641/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2642STATIC OP *
cea2e8a9 2643S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW		 2644{
2645 dSP;
533c011a 2646 OP *saveop = PL_op;
ff3ff8d1 2647 CV *caller;
748a9306 2648 AV* comppadlist;
67a38de0 2649 I32 i;
a0d0e21e 2650
faef0170 2651 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2652
1ce6579f 2653 PUSHMARK(SP);
2654
a0d0e21e
LW		 2655 /* set up a scratch pad */
2656
3280af22 2657 SAVEI32(PL_padix);
7766f137 2658 SAVEVPTR(PL_curpad);
3280af22
NIS		 2659 SAVESPTR(PL_comppad);
2660 SAVESPTR(PL_comppad_name);
2661 SAVEI32(PL_comppad_name_fill);
2662 SAVEI32(PL_min_intro_pending);
2663 SAVEI32(PL_max_intro_pending);
748a9306 2664
3280af22 2665 caller = PL_compcv;
6b35e009 2666 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2667 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2668 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2669 break;
7766f137 2670 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
67a38de0
NIS		 2671 caller = cx->blk_sub.cv;
2672 break;
2673 }
2674 }
2675
3280af22
NIS		 2676 SAVESPTR(PL_compcv);
2677 PL_compcv = (CV*)NEWSV(1104,0);
2678 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2679 CvEVAL_on(PL_compcv);
11343788 2680#ifdef USE_THREADS
533c011a
NIS		 2681 CvOWNER(PL_compcv) = 0;
2682 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2683 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2684#endif /* USE_THREADS */
748a9306 2685
3280af22
NIS		 2686 PL_comppad = newAV();
2687 av_push(PL_comppad, Nullsv);
2688 PL_curpad = AvARRAY(PL_comppad);
2689 PL_comppad_name = newAV();
2690 PL_comppad_name_fill = 0;
2691 PL_min_intro_pending = 0;
2692 PL_padix = 0;
11343788 2693#ifdef USE_THREADS
79cb57f6 2694 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 2695 PL_curpad[0] = (SV*)newAV();
2696 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2697#endif /* USE_THREADS */
a0d0e21e 2698
748a9306
LW		 2699 comppadlist = newAV();
2700 AvREAL_off(comppadlist);
3280af22
NIS		 2701 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2702 av_store(comppadlist, 1, (SV*)PL_comppad);
2703 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2704
c277df42 2705 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2706 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2707
3280af22 2708 SAVEFREESV(PL_compcv);
748a9306 2709
a0d0e21e
LW		 2710 /* make sure we compile in the right package */
2711
ed094faf 2712 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2713 SAVESPTR(PL_curstash);
ed094faf 2714 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2715 }
3280af22
NIS		 2716 SAVESPTR(PL_beginav);
2717 PL_beginav = newAV();
2718 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2719
2720 /* try to compile it */
2721
3280af22
NIS		 2722 PL_eval_root = Nullop;
2723 PL_error_count = 0;
2724 PL_curcop = &PL_compiling;
2725 PL_curcop->cop_arybase = 0;
2726 SvREFCNT_dec(PL_rs);
79cb57f6 2727 PL_rs = newSVpvn("\n", 1);
c277df42 2728 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2729 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2730 else
38a03e6e 2731 sv_setpv(ERRSV,"");
3280af22 2732 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2733 SV **newsp;
2734 I32 gimme;
c09156bb 2735 PERL_CONTEXT *cx;
c277df42 2736 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2737 STRLEN n_a;
097ee67d 2738
533c011a 2739 PL_op = saveop;
3280af22
NIS		 2740 if (PL_eval_root) {
2741 op_free(PL_eval_root);
2742 PL_eval_root = Nullop;
a0d0e21e 2743 }
3280af22 2744 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2745 if (!startop) {
3280af22 2746 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2747 POPEVAL(cx);
2748 pop_return();
2749 }
a0d0e21e
LW		 2750 lex_end();
2751 LEAVE;
7a2e2cd6 2752 if (optype == OP_REQUIRE) {
2d8e6c8d 2753 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 2754 DIE(aTHX_ "%sCompilation failed in require",
2755 *msg ? msg : "Unknown error\n");
2756 }
2757 else if (startop) {
2d8e6c8d 2758 char* msg = SvPVx(ERRSV, n_a);
c277df42 2759
3280af22 2760 POPBLOCK(cx,PL_curpm);
c277df42 2761 POPEVAL(cx);
5a844595
GS		 2762 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2763 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2764 }
3280af22
NIS		 2765 SvREFCNT_dec(PL_rs);
2766 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2767#ifdef USE_THREADS
533c011a
NIS		 2768 MUTEX_LOCK(&PL_eval_mutex);
2769 PL_eval_owner = 0;
2770 COND_SIGNAL(&PL_eval_cond);
2771 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2772#endif /* USE_THREADS */
a0d0e21e
LW		 2773 RETPUSHUNDEF;
2774 }
3280af22
NIS		 2775 SvREFCNT_dec(PL_rs);
2776 PL_rs = SvREFCNT_inc(PL_nrs);
57843af0 2777 CopLINE_set(&PL_compiling, 0);
c277df42 2778 if (startop) {
3280af22
NIS		 2779 *startop = PL_eval_root;
2780 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2781 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2782 } else
3280af22 2783 SAVEFREEOP(PL_eval_root);
54310121 2784 if (gimme & G_VOID)
3280af22 2785 scalarvoid(PL_eval_root);
54310121 2786 else if (gimme & G_ARRAY)
3280af22 2787 list(PL_eval_root);
a0d0e21e 2788 else
3280af22 2789 scalar(PL_eval_root);
a0d0e21e
LW		 2790
2791 DEBUG_x(dump_eval());
2792
55497cff 2793 /* Register with debugger: */
84902520 2794 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2795 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2796 if (cv) {
2797 dSP;
924508f0 2798 PUSHMARK(SP);
cc49e20b 2799 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2800 PUTBACK;
864dbfa3 2801 call_sv((SV*)cv, G_DISCARD);
55497cff 2802 }
2803 }
2804
a0d0e21e
LW		 2805 /* compiled okay, so do it */
2806
3280af22
NIS		 2807 CvDEPTH(PL_compcv) = 1;
2808 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2809 PL_op = saveop; /* The caller may need it. */
b35b2403 2810#ifdef USE_THREADS
533c011a
NIS		 2811 MUTEX_LOCK(&PL_eval_mutex);
2812 PL_eval_owner = 0;
2813 COND_SIGNAL(&PL_eval_cond);
2814 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2815#endif /* USE_THREADS */
5dc0d613 2816
3280af22 2817 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2818}
2819
a6c40364 2820STATIC PerlIO *
cea2e8a9 2821S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2822{
2823 STRLEN namelen = strlen(name);
2824 PerlIO *fp;
2825
7894fbab 2826 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2827 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2828 char *pmc = SvPV_nolen(pmcsv);
2829 Stat_t pmstat;
a6c40364
GS		 2830 Stat_t pmcstat;
2831 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2832 fp = PerlIO_open(name, mode);
a6c40364
GS		 2833 }
2834 else {
b295d113 2835 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2836 pmstat.st_mtime < pmcstat.st_mtime)
2837 {
2838 fp = PerlIO_open(pmc, mode);
2839 }
2840 else {
2841 fp = PerlIO_open(name, mode);
2842 }
b295d113 2843 }
a6c40364
GS		 2844 SvREFCNT_dec(pmcsv);
2845 }
2846 else {
2847 fp = PerlIO_open(name, mode);
b295d113 2848 }
b295d113
TH		 2849 return fp;
2850}
2851
a0d0e21e
LW		 2852PP(pp_require)
2853{
4e35701f 2854 djSP;
c09156bb 2855 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2856 SV *sv;
2857 char *name;
6132ea6c 2858 STRLEN len;
46fc3d4c 2859 char *tryname;
2860 SV *namesv = Nullsv;
a0d0e21e
LW		 2861 SV** svp;
2862 I32 gimme = G_SCALAR;
760ac839 2863 PerlIO *tryrsfp = 0;
2d8e6c8d 2864 STRLEN n_a;
bbed91b5
KF		 2865 int filter_has_file = 0;
2866 GV *filter_child_proc = 0;
2867 SV *filter_state = 0;
2868 SV *filter_sub = 0;
a0d0e21e
LW		 2869
2870 sv = POPs;
a7cb1f99
GS		 2871 if (SvNIOKp(sv)) {
2872 UV rev, ver, sver;
3818b22b 2873 if (SvPOKp(sv)) { /* require v5.6.1 */
a7cb1f99
GS		 2874 I32 len;
2875 U8 *s = (U8*)SvPVX(sv);
2876 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2877 if (s < end) {
2878 rev = utf8_to_uv(s, &len);
2879 s += len;
2880 if (s < end) {
2881 ver = utf8_to_uv(s, &len);
2882 s += len;
2883 if (s < end)
2884 sver = utf8_to_uv(s, &len);
2885 else
2886 sver = 0;
2887 }
2888 else
2889 ver = 0;
2890 }
2891 else
2892 rev = 0;
2893 if (PERL_REVISION < rev
2894 || (PERL_REVISION == rev
2895 && (PERL_VERSION < ver
2896 || (PERL_VERSION == ver
2897 && PERL_SUBVERSION < sver))))
2898 {
2899 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
894356b3 2900 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS		 2901 PERL_VERSION, PERL_SUBVERSION);
2902 }
2903 }
2904 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2905 NV n = SvNV(sv);
2906 rev = (UV)n;
2907 ver = (UV)((n-rev)*1000);
2908 sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2909
2910 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2911 + ((NV)PERL_SUBVERSION/(NV)1000000)
2912 + 0.00000099 < SvNV(sv))
2913 {
2914 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
894356b3 2915 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS		 2916 PERL_VERSION, PERL_SUBVERSION);
2917 }
2918 }
a0d0e21e
LW		 2919 RETPUSHYES;
2920 }
6132ea6c
GS		 2921 name = SvPV(sv, len);
2922 if (!(name && len > 0 && *name))
cea2e8a9 2923 DIE(aTHX_ "Null filename used");
4633a7c4 2924 TAINT_PROPER("require");
533c011a 2925 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2926 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2927 *svp != &PL_sv_undef)
a0d0e21e
LW		 2928 RETPUSHYES;
2929
2930 /* prepare to compile file */
2931
57843af0
GS		 2932 if (PERL_FILE_IS_ABSOLUTE(name)
2933 || (*name == '.' && (name[1] == '/' ||
2934 (name[1] == '.' && name[2] == '/'))))
a0d0e21e 2935 {
46fc3d4c 2936 tryname = name;
a6c40364 2937 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2938 }
2939 else {
3280af22 2940 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2941 I32 i;
748a9306 2942#ifdef VMS
46fc3d4c 2943 char *unixname;
2944 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2945#endif
2946 {
2947 namesv = NEWSV(806, 0);
2948 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 2949 SV *dirsv = *av_fetch(ar, i, TRUE);
2950
2951 if (SvROK(dirsv)) {
2952 int count;
2953 SV *loader = dirsv;
2954
2955 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2956 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2957 }
2958
b900a521
JH		 2959 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2960 PTR2UV(SvANY(loader)), name);
bbed91b5
KF		 2961 tryname = SvPVX(namesv);
2962 tryrsfp = 0;
2963
2964 ENTER;
2965 SAVETMPS;
2966 EXTEND(SP, 2);
2967
2968 PUSHMARK(SP);
2969 PUSHs(dirsv);
2970 PUSHs(sv);
2971 PUTBACK;
2972 count = call_sv(loader, G_ARRAY);
2973 SPAGAIN;
2974
2975 if (count > 0) {
2976 int i = 0;
2977 SV *arg;
2978
2979 SP -= count - 1;
2980 arg = SP[i++];
2981
2982 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2983 arg = SvRV(arg);
2984 }
2985
2986 if (SvTYPE(arg) == SVt_PVGV) {
2987 IO *io = GvIO((GV *)arg);
2988
2989 ++filter_has_file;
2990
2991 if (io) {
2992 tryrsfp = IoIFP(io);
2993 if (IoTYPE(io) == '|') {
2994 /* reading from a child process doesn't
2995 nest -- when returning from reading
2996 the inner module, the outer one is
2997 unreadable (closed?) I've tried to
2998 save the gv to manage the lifespan of
2999 the pipe, but this didn't help. XXX */
3000 filter_child_proc = (GV *)arg;
520c758a 3001 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3002 }
3003 else {
3004 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3005 PerlIO_close(IoOFP(io));
3006 }
3007 IoIFP(io) = Nullfp;
3008 IoOFP(io) = Nullfp;
3009 }
3010 }
3011
3012 if (i < count) {
3013 arg = SP[i++];
3014 }
3015 }
3016
3017 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3018 filter_sub = arg;
520c758a 3019 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3020
3021 if (i < count) {
3022 filter_state = SP[i];
520c758a 3023 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3024 }
3025
3026 if (tryrsfp == 0) {
3027 tryrsfp = PerlIO_open("/dev/null",
3028 PERL_SCRIPT_MODE);
3029 }
3030 }
3031 }
3032
3033 PUTBACK;
3034 FREETMPS;
3035 LEAVE;
3036
3037 if (tryrsfp) {
3038 break;
3039 }
3040
3041 filter_has_file = 0;
3042 if (filter_child_proc) {
3043 SvREFCNT_dec(filter_child_proc);
3044 filter_child_proc = 0;
3045 }
3046 if (filter_state) {
3047 SvREFCNT_dec(filter_state);
3048 filter_state = 0;
3049 }
3050 if (filter_sub) {
3051 SvREFCNT_dec(filter_sub);
3052 filter_sub = 0;
3053 }
3054 }
3055 else {
3056 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 3057#ifdef VMS
bbed91b5
KF		 3058 char *unixdir;
3059 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3060 continue;
3061 sv_setpv(namesv, unixdir);
3062 sv_catpv(namesv, unixname);
748a9306 3063#else
bbed91b5 3064 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3065#endif
bbed91b5
KF		 3066 TAINT_PROPER("require");
3067 tryname = SvPVX(namesv);
3068 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3069 if (tryrsfp) {
3070 if (tryname[0] == '.' && tryname[1] == '/')
3071 tryname += 2;
3072 break;
3073 }
46fc3d4c 3074 }
a0d0e21e
LW		 3075 }
3076 }
3077 }
57843af0
GS		 3078 SAVECOPFILE(&PL_compiling);
3079 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3080 SvREFCNT_dec(namesv);
a0d0e21e 3081 if (!tryrsfp) {
533c011a 3082 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 3083 char *msgstr = name;
3084 if (namesv) { /* did we lookup @INC? */
3085 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3086 SV *dirmsgsv = NEWSV(0, 0);
3087 AV *ar = GvAVn(PL_incgv);
3088 I32 i;
3089 sv_catpvn(msg, " in @INC", 8);
3090 if (instr(SvPVX(msg), ".h "))
3091 sv_catpv(msg, " (change .h to .ph maybe?)");
3092 if (instr(SvPVX(msg), ".ph "))
3093 sv_catpv(msg, " (did you run h2ph?)");
3094 sv_catpv(msg, " (@INC contains:");
3095 for (i = 0; i <= AvFILL(ar); i++) {
3096 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3097 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3098 sv_catsv(msg, dirmsgsv);
3099 }
3100 sv_catpvn(msg, ")", 1);
3101 SvREFCNT_dec(dirmsgsv);
3102 msgstr = SvPV_nolen(msg);
2683423c 3103 }
cea2e8a9 3104 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3105 }
3106
3107 RETPUSHUNDEF;
3108 }
d8bfb8bd 3109 else
aba27d88 3110 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 3111
3112 /* Assume success here to prevent recursive requirement. */
3280af22 3113 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
ed094faf 3114 newSVpv(CopFILE(&PL_compiling), 0), 0 );
a0d0e21e
LW		 3115
3116 ENTER;
3117 SAVETMPS;
79cb57f6 3118 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3119 SAVEGENERICSV(PL_rsfp_filters);
3120 PL_rsfp_filters = Nullav;
e50aee73 3121
3280af22 3122 PL_rsfp = tryrsfp;
b3ac6de7 3123 SAVEHINTS();
3280af22 3124 PL_hints = 0;
7766f137 3125 SAVESPTR(PL_compiling.cop_warnings);
0453d815
PM		 3126 if (PL_dowarn & G_WARN_ALL_ON)
3127 PL_compiling.cop_warnings = WARN_ALL ;
3128 else if (PL_dowarn & G_WARN_ALL_OFF)
3129 PL_compiling.cop_warnings = WARN_NONE ;
3130 else
3131 PL_compiling.cop_warnings = WARN_STD ;
a0d0e21e 3132
bbed91b5
KF		 3133 if (filter_sub || filter_child_proc) {
3134 SV *datasv = filter_add(run_user_filter, Nullsv);
3135 IoLINES(datasv) = filter_has_file;
3136 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3137 IoTOP_GV(datasv) = (GV *)filter_state;
3138 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3139 }
3140
3141 /* switch to eval mode */
533c011a 3142 push_return(PL_op->op_next);
a0d0e21e 3143 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3144 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3145
57843af0
GS		 3146 SAVECOPLINE(&PL_compiling);
3147 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3148
3149 PUTBACK;
0f15f207 3150#ifdef USE_THREADS
533c011a
NIS		 3151 MUTEX_LOCK(&PL_eval_mutex);
3152 if (PL_eval_owner && PL_eval_owner != thr)
3153 while (PL_eval_owner)
3154 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3155 PL_eval_owner = thr;
3156 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3157#endif /* USE_THREADS */
c277df42 3158 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 3159}
3160
3161PP(pp_dofile)
3162{
cea2e8a9 3163 return pp_require();
a0d0e21e
LW		 3164}
3165
3166PP(pp_entereval)
3167{
4e35701f 3168 djSP;
c09156bb 3169 register PERL_CONTEXT *cx;
a0d0e21e 3170 dPOPss;
3280af22 3171 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3172 char tbuf[TYPE_DIGITS(long) + 12];
3173 char *tmpbuf = tbuf;
fc36a67e 3174 char *safestr;
a0d0e21e 3175 STRLEN len;
55497cff 3176 OP *ret;
a0d0e21e
LW		 3177
3178 if (!SvPV(sv,len) || !len)
3179 RETPUSHUNDEF;
748a9306 3180 TAINT_PROPER("eval");
a0d0e21e
LW		 3181
3182 ENTER;
a0d0e21e 3183 lex_start(sv);
748a9306 3184 SAVETMPS;
a0d0e21e
LW		 3185
3186 /* switch to eval mode */
3187
57843af0 3188 SAVECOPFILE(&PL_compiling);
83ee9e09
GS		 3189 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3190 SV *sv = sv_newmortal();
3191 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3192 (unsigned long)++PL_evalseq,
3193 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3194 tmpbuf = SvPVX(sv);
3195 }
3196 else
3197 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
57843af0
GS		 3198 CopFILE_set(&PL_compiling, tmpbuf+2);
3199 CopLINE_set(&PL_compiling, 1);
55497cff 3200 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3201 deleting the eval's FILEGV from the stash before gv_check() runs
3202 (i.e. before run-time proper). To work around the coredump that
3203 ensues, we always turn GvMULTI_on for any globals that were
3204 introduced within evals. See force_ident(). GSAR 96-10-12 */
3205 safestr = savepv(tmpbuf);
3280af22 3206 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3207 SAVEHINTS();
533c011a 3208 PL_hints = PL_op->op_targ;
7766f137 3209 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3210 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 3211 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3212 SAVEFREESV(PL_compiling.cop_warnings) ;
3213 }
a0d0e21e 3214
533c011a 3215 push_return(PL_op->op_next);
6b35e009 3216 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3217 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW		 3218
3219 /* prepare to compile string */
3220
3280af22 3221 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3222 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3223 PUTBACK;
0f15f207 3224#ifdef USE_THREADS
533c011a
NIS		 3225 MUTEX_LOCK(&PL_eval_mutex);
3226 if (PL_eval_owner && PL_eval_owner != thr)
3227 while (PL_eval_owner)
3228 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3229 PL_eval_owner = thr;
3230 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3231#endif /* USE_THREADS */
c277df42 3232 ret = doeval(gimme, NULL);
3280af22 3233 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3234 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3235 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3236 }
1e422769 3237 return DOCATCH(ret);
a0d0e21e
LW		 3238}
3239
3240PP(pp_leaveeval)
3241{
4e35701f 3242 djSP;
a0d0e21e
LW		 3243 register SV **mark;
3244 SV **newsp;
3245 PMOP *newpm;
3246 I32 gimme;
c09156bb 3247 register PERL_CONTEXT *cx;
a0d0e21e 3248 OP *retop;
533c011a 3249 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3250 I32 optype;
3251
3252 POPBLOCK(cx,newpm);
3253 POPEVAL(cx);
3254 retop = pop_return();
3255
a1f49e72 3256 TAINT_NOT;
54310121 3257 if (gimme == G_VOID)
3258 MARK = newsp;
3259 else if (gimme == G_SCALAR) {
3260 MARK = newsp + 1;
3261 if (MARK <= SP) {
3262 if (SvFLAGS(TOPs) & SVs_TEMP)
3263 *MARK = TOPs;
3264 else
3265 *MARK = sv_mortalcopy(TOPs);
3266 }
a0d0e21e 3267 else {
54310121 3268 MEXTEND(mark,0);
3280af22 3269 *MARK = &PL_sv_undef;
a0d0e21e 3270 }
a7ec2b44 3271 SP = MARK;
a0d0e21e
LW		 3272 }
3273 else {
a1f49e72
CS		 3274 /* in case LEAVE wipes old return values */
3275 for (mark = newsp + 1; mark <= SP; mark++) {
3276 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3277 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3278 TAINT_NOT; /* Each item is independent */
3279 }
3280 }
a0d0e21e 3281 }
3280af22 3282 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3283
067f92a0
GS		 3284 if (AvFILLp(PL_comppad_name) >= 0)
3285 free_closures();
84902520 3286
4fdae800 3287#ifdef DEBUGGING
3280af22 3288 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3289#endif
3280af22 3290 CvDEPTH(PL_compcv) = 0;
f46d017c 3291 lex_end();
4fdae800 3292
1ce6579f 3293 if (optype == OP_REQUIRE &&
924508f0 3294 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3295 {
1ce6579f 3296 /* Unassume the success we assumed earlier. */
54310121 3297 char *name = cx->blk_eval.old_name;
3280af22 3298 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 3299 retop = Perl_die(aTHX_ "%s did not return a true value", name);
f46d017c
GS		 3300 /* die_where() did LEAVE, or we won't be here */
3301 }
3302 else {
3303 LEAVE;
3304 if (!(save_flags & OPf_SPECIAL))
3305 sv_setpv(ERRSV,"");
a0d0e21e 3306 }
a0d0e21e
LW		 3307
3308 RETURNOP(retop);
3309}
3310
a0d0e21e
LW		 3311PP(pp_entertry)
3312{
4e35701f 3313 djSP;
c09156bb 3314 register PERL_CONTEXT *cx;
54310121 3315 I32 gimme = GIMME_V;
a0d0e21e
LW		 3316
3317 ENTER;
3318 SAVETMPS;
3319
3320 push_return(cLOGOP->op_other->op_next);
3321 PUSHBLOCK(cx, CXt_EVAL, SP);
3322 PUSHEVAL(cx, 0, 0);
533c011a 3323 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3324
faef0170 3325 PL_in_eval = EVAL_INEVAL;
38a03e6e 3326 sv_setpv(ERRSV,"");
1e422769 3327 PUTBACK;
533c011a 3328 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3329}
3330
3331PP(pp_leavetry)
3332{
4e35701f 3333 djSP;
a0d0e21e
LW		 3334 register SV **mark;
3335 SV **newsp;
3336 PMOP *newpm;
3337 I32 gimme;
c09156bb 3338 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3339 I32 optype;
3340
3341 POPBLOCK(cx,newpm);
3342 POPEVAL(cx);
3343 pop_return();
3344
a1f49e72 3345 TAINT_NOT;
54310121 3346 if (gimme == G_VOID)
3347 SP = newsp;
3348 else if (gimme == G_SCALAR) {
3349 MARK = newsp + 1;
3350 if (MARK <= SP) {
3351 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3352 *MARK = TOPs;
3353 else
3354 *MARK = sv_mortalcopy(TOPs);
3355 }
a0d0e21e 3356 else {
54310121 3357 MEXTEND(mark,0);
3280af22 3358 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3359 }
3360 SP = MARK;
3361 }
3362 else {
a1f49e72
CS		 3363 /* in case LEAVE wipes old return values */
3364 for (mark = newsp + 1; mark <= SP; mark++) {
3365 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3366 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3367 TAINT_NOT; /* Each item is independent */
3368 }
3369 }
a0d0e21e 3370 }
3280af22 3371 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3372
3373 LEAVE;
38a03e6e 3374 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3375 RETURN;
3376}
3377
0824fdcb 3378STATIC void
cea2e8a9 3379S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3380{
3381 STRLEN len;
3382 register char *s = SvPV_force(sv, len);
3383 register char *send = s + len;
3384 register char *base;
3385 register I32 skipspaces = 0;
3386 bool noblank;
3387 bool repeat;
3388 bool postspace = FALSE;
3389 U16 *fops;
3390 register U16 *fpc;
3391 U16 *linepc;
3392 register I32 arg;
3393 bool ischop;
3394
55497cff 3395 if (len == 0)
cea2e8a9 3396 Perl_croak(aTHX_ "Null picture in formline");
55497cff 3397
3398 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3399 fpc = fops;
3400
3401 if (s < send) {
3402 linepc = fpc;
3403 *fpc++ = FF_LINEMARK;
3404 noblank = repeat = FALSE;
3405 base = s;
3406 }
3407
3408 while (s <= send) {
3409 switch (*s++) {
3410 default:
3411 skipspaces = 0;
3412 continue;
3413
3414 case '~':
3415 if (*s == '~') {
3416 repeat = TRUE;
3417 *s = ' ';
3418 }
3419 noblank = TRUE;
3420 s[-1] = ' ';
3421 /* FALL THROUGH */
3422 case ' ': case '\t':
3423 skipspaces++;
3424 continue;
3425
3426 case '\n': case 0:
3427 arg = s - base;
3428 skipspaces++;
3429 arg -= skipspaces;
3430 if (arg) {
5f05dabc 3431 if (postspace)
a0d0e21e 3432 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3433 *fpc++ = FF_LITERAL;
3434 *fpc++ = arg;
3435 }
5f05dabc 3436 postspace = FALSE;
a0d0e21e
LW		 3437 if (s <= send)
3438 skipspaces--;
3439 if (skipspaces) {
3440 *fpc++ = FF_SKIP;
3441 *fpc++ = skipspaces;
3442 }
3443 skipspaces = 0;
3444 if (s <= send)
3445 *fpc++ = FF_NEWLINE;
3446 if (noblank) {
3447 *fpc++ = FF_BLANK;
3448 if (repeat)
3449 arg = fpc - linepc + 1;
3450 else
3451 arg = 0;
3452 *fpc++ = arg;
3453 }
3454 if (s < send) {
3455 linepc = fpc;
3456 *fpc++ = FF_LINEMARK;
3457 noblank = repeat = FALSE;
3458 base = s;
3459 }
3460 else
3461 s++;
3462 continue;
3463
3464 case '@':
3465 case '^':
3466 ischop = s[-1] == '^';
3467
3468 if (postspace) {
3469 *fpc++ = FF_SPACE;
3470 postspace = FALSE;
3471 }
3472 arg = (s - base) - 1;
3473 if (arg) {
3474 *fpc++ = FF_LITERAL;
3475 *fpc++ = arg;
3476 }
3477
3478 base = s - 1;
3479 *fpc++ = FF_FETCH;
3480 if (*s == '*') {
3481 s++;
3482 *fpc++ = 0;
3483 *fpc++ = FF_LINEGLOB;
3484 }
3485 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3486 arg = ischop ? 512 : 0;
3487 base = s - 1;
3488 while (*s == '#')
3489 s++;
3490 if (*s == '.') {
3491 char *f;
3492 s++;
3493 f = s;
3494 while (*s == '#')
3495 s++;
3496 arg |= 256 + (s - f);
3497 }
3498 *fpc++ = s - base; /* fieldsize for FETCH */
3499 *fpc++ = FF_DECIMAL;
3500 *fpc++ = arg;
3501 }
3502 else {
3503 I32 prespace = 0;
3504 bool ismore = FALSE;
3505
3506 if (*s == '>') {
3507 while (*++s == '>') ;
3508 prespace = FF_SPACE;
3509 }
3510 else if (*s == '|') {
3511 while (*++s == '|') ;
3512 prespace = FF_HALFSPACE;
3513 postspace = TRUE;
3514 }
3515 else {
3516 if (*s == '<')
3517 while (*++s == '<') ;
3518 postspace = TRUE;
3519 }
3520 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3521 s += 3;
3522 ismore = TRUE;
3523 }
3524 *fpc++ = s - base; /* fieldsize for FETCH */
3525
3526 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3527
3528 if (prespace)
3529 *fpc++ = prespace;
3530 *fpc++ = FF_ITEM;
3531 if (ismore)
3532 *fpc++ = FF_MORE;
3533 if (ischop)
3534 *fpc++ = FF_CHOP;
3535 }
3536 base = s;
3537 skipspaces = 0;
3538 continue;
3539 }
3540 }
3541 *fpc++ = FF_END;
3542
3543 arg = fpc - fops;
3544 { /* need to jump to the next word */
3545 int z;
3546 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3547 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3548 s = SvPVX(sv) + SvCUR(sv) + z;
3549 }
3550 Copy(fops, s, arg, U16);
3551 Safefree(fops);
55497cff 3552 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3553 SvCOMPILED_on(sv);
3554}
4e35701f 3555
745d3a65
HM		 3556/*
3557 * The rest of this file was derived from source code contributed
3558 * by Tom Horsley.
3559 *
3560 * NOTE: this code was derived from Tom Horsley's qsort replacement
3561 * and should not be confused with the original code.
3562 */
3563
3564/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3565
3566 Permission granted to distribute under the same terms as perl which are
3567 (briefly):
3568
3569 This program is free software; you can redistribute it and/or modify
3570 it under the terms of either:
3571
3572 a) the GNU General Public License as published by the Free
3573 Software Foundation; either version 1, or (at your option) any
3574 later version, or
3575
3576 b) the "Artistic License" which comes with this Kit.
3577
3578 Details on the perl license can be found in the perl source code which
3579 may be located via the www.perl.com web page.
3580
3581 This is the most wonderfulest possible qsort I can come up with (and
3582 still be mostly portable) My (limited) tests indicate it consistently
3583 does about 20% fewer calls to compare than does the qsort in the Visual
3584 C++ library, other vendors may vary.
3585
3586 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3587 others I invented myself (or more likely re-invented since they seemed
3588 pretty obvious once I watched the algorithm operate for a while).
3589
3590 Most of this code was written while watching the Marlins sweep the Giants
3591 in the 1997 National League Playoffs - no Braves fans allowed to use this
3592 code (just kidding :-).
3593
3594 I realize that if I wanted to be true to the perl tradition, the only
3595 comment in this file would be something like:
3596
3597 ...they shuffled back towards the rear of the line. 'No, not at the
3598 rear!' the slave-driver shouted. 'Three files up. And stay there...
3599
3600 However, I really needed to violate that tradition just so I could keep
3601 track of what happens myself, not to mention some poor fool trying to
3602 understand this years from now :-).
3603*/
3604
3605/* ********************************************************** Configuration */
3606
3607#ifndef QSORT_ORDER_GUESS
3608#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3609#endif
3610
3611/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3612 future processing - a good max upper bound is log base 2 of memory size
3613 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3614 safely be smaller than that since the program is taking up some space and
3615 most operating systems only let you grab some subset of contiguous
3616 memory (not to mention that you are normally sorting data larger than
3617 1 byte element size :-).
3618*/
3619#ifndef QSORT_MAX_STACK
3620#define QSORT_MAX_STACK 32
3621#endif
3622
3623/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3624 Anything bigger and we use qsort. If you make this too small, the qsort
3625 will probably break (or become less efficient), because it doesn't expect
3626 the middle element of a part