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