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