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