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