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