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