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