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