3 * Copyright (c) 1991-1997, Larry Wall
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.
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.
23 #define WORD_ALIGN sizeof(U16)
26 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 #define CALLOP this->*op
32 static OP *docatch _((OP *o));
33 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
34 static void doparseform _((SV *sv));
35 static I32 dopoptoeval _((I32 startingblock));
36 static I32 dopoptolabel _((char *label));
37 static I32 dopoptoloop _((I32 startingblock));
38 static I32 dopoptosub _((I32 startingblock));
39 static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
40 static void save_lines _((AV *array, SV *sv));
41 static I32 sortcv _((SV *a, SV *b));
42 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
43 static OP *doeval _((int gimme, OP** startop));
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
73 /* XXXX Should store the old value to allow for tie/overload - and
74 restore in regcomp, where marked with XXXX. */
82 register PMOP *pm = (PMOP*)cLOGOP->op_other;
86 MAGIC *mg = Null(MAGIC*);
90 SV *sv = SvRV(tmpstr);
92 mg = mg_find(sv, 'r');
95 regexp *re = (regexp *)mg->mg_obj;
96 ReREFCNT_dec(pm->op_pmregexp);
97 pm->op_pmregexp = ReREFCNT_inc(re);
100 t = SvPV(tmpstr, len);
102 /* Check against the last compiled regexp. */
103 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
104 pm->op_pmregexp->prelen != len ||
105 memNE(pm->op_pmregexp->precomp, t, len))
107 if (pm->op_pmregexp) {
108 ReREFCNT_dec(pm->op_pmregexp);
109 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
111 if (op->op_flags & OPf_SPECIAL)
112 reginterp_cnt = I32_MAX; /* Mark as safe. */
114 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
115 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
116 reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
117 inside tie/overload accessors. */
121 #ifndef INCOMPLETE_TAINTS
124 pm->op_pmdynflags |= PMdf_TAINTED;
126 pm->op_pmdynflags &= ~PMdf_TAINTED;
130 if (!pm->op_pmregexp->prelen && curpm)
132 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
133 pm->op_pmflags |= PMf_WHITE;
135 if (pm->op_pmflags & PMf_KEEP) {
136 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
137 cLOGOP->op_first->op_next = op->op_next;
145 register PMOP *pm = (PMOP*) cLOGOP->op_other;
146 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
147 register SV *dstr = cx->sb_dstr;
148 register char *s = cx->sb_s;
149 register char *m = cx->sb_m;
150 char *orig = cx->sb_orig;
151 register REGEXP *rx = cx->sb_rx;
153 rxres_restore(&cx->sb_rxres, rx);
155 if (cx->sb_iters++) {
156 if (cx->sb_iters > cx->sb_maxiters)
157 DIE("Substitution loop");
159 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
160 cx->sb_rxtainted |= 2;
161 sv_catsv(dstr, POPs);
164 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
165 s == m, Nullsv, NULL,
166 cx->sb_safebase ? 0 : REXEC_COPY_STR))
168 SV *targ = cx->sb_targ;
169 sv_catpvn(dstr, s, cx->sb_strend - s);
171 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
173 (void)SvOOK_off(targ);
174 Safefree(SvPVX(targ));
175 SvPVX(targ) = SvPVX(dstr);
176 SvCUR_set(targ, SvCUR(dstr));
177 SvLEN_set(targ, SvLEN(dstr));
181 TAINT_IF(cx->sb_rxtainted & 1);
182 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
184 (void)SvPOK_only(targ);
185 TAINT_IF(cx->sb_rxtainted);
189 LEAVE_SCOPE(cx->sb_oldsave);
191 RETURNOP(pm->op_next);
194 if (rx->subbase && rx->subbase != orig) {
197 cx->sb_orig = orig = rx->subbase;
199 cx->sb_strend = s + (cx->sb_strend - m);
201 cx->sb_m = m = rx->startp[0];
202 sv_catpvn(dstr, s, m-s);
203 cx->sb_s = rx->endp[0];
204 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
205 rxres_save(&cx->sb_rxres, rx);
206 RETURNOP(pm->op_pmreplstart);
210 rxres_save(void **rsp, REGEXP *rx)
215 if (!p || p[1] < rx->nparens) {
216 i = 6 + rx->nparens * 2;
224 *p++ = (UV)rx->subbase;
225 rx->subbase = Nullch;
229 *p++ = (UV)rx->subbeg;
230 *p++ = (UV)rx->subend;
231 for (i = 0; i <= rx->nparens; ++i) {
232 *p++ = (UV)rx->startp[i];
233 *p++ = (UV)rx->endp[i];
238 rxres_restore(void **rsp, REGEXP *rx)
243 Safefree(rx->subbase);
244 rx->subbase = (char*)(*p);
249 rx->subbeg = (char*)(*p++);
250 rx->subend = (char*)(*p++);
251 for (i = 0; i <= rx->nparens; ++i) {
252 rx->startp[i] = (char*)(*p++);
253 rx->endp[i] = (char*)(*p++);
258 rxres_free(void **rsp)
263 Safefree((char*)(*p));
271 djSP; dMARK; dORIGMARK;
272 register SV *tmpForm = *++MARK;
284 bool chopspace = (strchr(chopset, ' ') != Nullch);
291 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
292 SvREADONLY_off(tmpForm);
293 doparseform(tmpForm);
296 SvPV_force(formtarget, len);
297 t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */
299 f = SvPV(tmpForm, len);
300 /* need to jump to the next word */
301 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
310 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
311 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
312 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
313 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
314 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
316 case FF_CHECKNL: name = "CHECKNL"; break;
317 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
318 case FF_SPACE: name = "SPACE"; break;
319 case FF_HALFSPACE: name = "HALFSPACE"; break;
320 case FF_ITEM: name = "ITEM"; break;
321 case FF_CHOP: name = "CHOP"; break;
322 case FF_LINEGLOB: name = "LINEGLOB"; break;
323 case FF_NEWLINE: name = "NEWLINE"; break;
324 case FF_MORE: name = "MORE"; break;
325 case FF_LINEMARK: name = "LINEMARK"; break;
326 case FF_END: name = "END"; break;
329 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
331 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
360 warn("Not enough format arguments");
365 item = s = SvPV(sv, len);
367 if (itemsize > fieldsize)
368 itemsize = fieldsize;
369 send = chophere = s + itemsize;
381 item = s = SvPV(sv, len);
383 if (itemsize <= fieldsize) {
384 send = chophere = s + itemsize;
395 itemsize = fieldsize;
396 send = chophere = s + itemsize;
397 while (s < send || (s == send && isSPACE(*s))) {
407 if (strchr(chopset, *s))
412 itemsize = chophere - item;
417 arg = fieldsize - itemsize;
426 arg = fieldsize - itemsize;
440 int ch = *t++ = *s++;
444 if ( !((*t++ = *s++) & ~31) )
454 while (*s && isSPACE(*s))
461 item = s = SvPV(sv, len);
474 SvCUR_set(formtarget, t - SvPVX(formtarget));
475 sv_catpvn(formtarget, item, itemsize);
476 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1);
477 t = SvPVX(formtarget) + SvCUR(formtarget);
482 /* If the field is marked with ^ and the value is undefined,
485 if ((arg & 512) && !SvOK(sv)) {
493 /* Formats aren't yet marked for locales, so assume "yes". */
496 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
498 sprintf(t, "%*.0f", (int) fieldsize, value);
505 while (t-- > linemark && *t == ' ') ;
513 if (arg) { /* repeat until fields exhausted? */
515 SvCUR_set(formtarget, t - SvPVX(formtarget));
516 lines += FmLINES(formtarget);
519 if (strnEQ(linemark, linemark - arg, arg))
520 DIE("Runaway format");
522 FmLINES(formtarget) = lines;
524 RETURNOP(cLISTOP->op_first);
535 arg = fieldsize - itemsize;
542 if (strnEQ(s," ",3)) {
543 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
554 SvCUR_set(formtarget, t - SvPVX(formtarget));
555 FmLINES(formtarget) += lines;
567 if (stack_base + *markstack_ptr == SP) {
569 if (GIMME_V == G_SCALAR)
571 RETURNOP(op->op_next->op_next);
573 stack_sp = stack_base + *markstack_ptr + 1;
574 pp_pushmark(ARGS); /* push dst */
575 pp_pushmark(ARGS); /* push src */
576 ENTER; /* enter outer scope */
580 /* SAVE_DEFSV does *not* suffice here */
581 save_sptr(&THREADSV(0));
583 SAVESPTR(GvSV(defgv));
584 #endif /* USE_THREADS */
585 ENTER; /* enter inner scope */
588 src = stack_base[*markstack_ptr];
593 if (op->op_type == OP_MAPSTART)
594 pp_pushmark(ARGS); /* push top */
595 return ((LOGOP*)op->op_next)->op_other;
600 DIE("panic: mapstart"); /* uses grepstart */
606 I32 diff = (SP - stack_base) - *markstack_ptr;
614 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
615 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
616 count = (SP - stack_base) - markstack_ptr[-1] + 2;
621 markstack_ptr[-1] += shift;
622 *markstack_ptr += shift;
626 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
629 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
631 LEAVE; /* exit inner scope */
634 if (markstack_ptr[-1] > *markstack_ptr) {
638 (void)POPMARK; /* pop top */
639 LEAVE; /* exit outer scope */
640 (void)POPMARK; /* pop src */
641 items = --*markstack_ptr - markstack_ptr[-1];
642 (void)POPMARK; /* pop dst */
643 SP = stack_base + POPMARK; /* pop original mark */
644 if (gimme == G_SCALAR) {
648 else if (gimme == G_ARRAY)
655 ENTER; /* enter inner scope */
658 src = stack_base[markstack_ptr[-1]];
662 RETURNOP(cLOGOP->op_other);
668 djSP; dMARK; dORIGMARK;
670 SV **myorigmark = ORIGMARK;
676 OP* nextop = op->op_next;
678 if (gimme != G_ARRAY) {
685 if (op->op_flags & OPf_STACKED) {
686 if (op->op_flags & OPf_SPECIAL) {
687 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
688 kid = kUNOP->op_first; /* pass rv2gv */
689 kid = kUNOP->op_first; /* pass leave */
690 sortcop = kid->op_next;
691 stash = curcop->cop_stash;
694 cv = sv_2cv(*++MARK, &stash, &gv, 0);
695 if (!(cv && CvROOT(cv))) {
697 SV *tmpstr = sv_newmortal();
698 gv_efullname3(tmpstr, gv, Nullch);
699 if (cv && CvXSUB(cv))
700 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
701 DIE("Undefined sort subroutine \"%s\" called",
706 DIE("Xsub called in sort");
707 DIE("Undefined subroutine in sort");
709 DIE("Not a CODE reference in sort");
711 sortcop = CvSTART(cv);
712 SAVESPTR(CvROOT(cv)->op_ppaddr);
713 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
716 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
721 stash = curcop->cop_stash;
725 while (MARK < SP) { /* This may or may not shift down one here. */
727 if (*up = *++MARK) { /* Weed out nulls. */
729 if (!sortcop && !SvPOK(*up))
730 (void)sv_2pv(*up, &na);
734 max = --up - myorigmark;
739 bool oldcatch = CATCH_GET;
745 PUSHSTACKi(PERLSI_SORT);
746 if (sortstash != stash) {
747 firstgv = gv_fetchpv("a", TRUE, SVt_PV);
748 secondgv = gv_fetchpv("b", TRUE, SVt_PV);
752 SAVESPTR(GvSV(firstgv));
753 SAVESPTR(GvSV(secondgv));
755 PUSHBLOCK(cx, CXt_NULL, stack_base);
756 if (!(op->op_flags & OPf_SPECIAL)) {
757 bool hasargs = FALSE;
758 cx->cx_type = CXt_SUB;
759 cx->blk_gimme = G_SCALAR;
762 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
764 sortcxix = cxstack_ix;
765 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
774 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
775 qsortsv(ORIGMARK+1, max,
776 (op->op_private & OPpLOCALE)
777 ? FUNC_NAME_TO_PTR(sv_cmp_locale)
778 : FUNC_NAME_TO_PTR(sv_cmp));
782 stack_sp = ORIGMARK + max;
790 if (GIMME == G_ARRAY)
791 return cCONDOP->op_true;
792 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
799 if (GIMME == G_ARRAY) {
800 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
804 SV *targ = PAD_SV(op->op_targ);
806 if ((op->op_private & OPpFLIP_LINENUM)
807 ? (last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(last_in_gv)))
809 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
810 if (op->op_flags & OPf_SPECIAL) {
818 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
831 if (GIMME == G_ARRAY) {
837 if (SvNIOKp(left) || !SvPOKp(left) ||
838 (looks_like_number(left) && *SvPVX(left) != '0') )
840 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
841 croak("Range iterator outside integer range");
845 EXTEND_MORTAL(max - i + 1);
846 EXTEND(SP, max - i + 1);
849 sv = sv_2mortal(newSViv(i++));
854 SV *final = sv_mortalcopy(right);
856 char *tmps = SvPV(final, len);
858 sv = sv_mortalcopy(left);
859 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
861 if (strEQ(SvPVX(sv),tmps))
863 sv = sv_2mortal(newSVsv(sv));
870 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
872 if ((op->op_private & OPpFLIP_LINENUM)
873 ? (last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(last_in_gv)))
875 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
876 sv_catpv(targ, "E0");
887 dopoptolabel(char *label)
891 register PERL_CONTEXT *cx;
893 for (i = cxstack_ix; i >= 0; i--) {
895 switch (cx->cx_type) {
898 warn("Exiting substitution via %s", op_name[op->op_type]);
902 warn("Exiting subroutine via %s", op_name[op->op_type]);
906 warn("Exiting eval via %s", op_name[op->op_type]);
910 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
913 if (!cx->blk_loop.label ||
914 strNE(label, cx->blk_loop.label) ) {
915 DEBUG_l(deb("(Skipping label #%ld %s)\n",
916 (long)i, cx->blk_loop.label));
919 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
929 I32 gimme = block_gimme();
930 return (gimme == G_VOID) ? G_SCALAR : gimme;
939 cxix = dopoptosub(cxstack_ix);
943 switch (cxstack[cxix].blk_gimme) {
951 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
958 dopoptosub(I32 startingblock)
961 return dopoptosub_at(cxstack, startingblock);
965 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
969 register PERL_CONTEXT *cx;
970 for (i = startingblock; i >= 0; i--) {
972 switch (cx->cx_type) {
977 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
985 dopoptoeval(I32 startingblock)
989 register PERL_CONTEXT *cx;
990 for (i = startingblock; i >= 0; i--) {
992 switch (cx->cx_type) {
996 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1004 dopoptoloop(I32 startingblock)
1008 register PERL_CONTEXT *cx;
1009 for (i = startingblock; i >= 0; i--) {
1011 switch (cx->cx_type) {
1014 warn("Exiting substitution via %s", op_name[op->op_type]);
1018 warn("Exiting subroutine via %s", op_name[op->op_type]);
1022 warn("Exiting eval via %s", op_name[op->op_type]);
1026 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
1029 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1040 register PERL_CONTEXT *cx;
1044 while (cxstack_ix > cxix) {
1045 cx = &cxstack[cxstack_ix];
1046 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1047 (long) cxstack_ix, block_type[cx->cx_type]));
1048 /* Note: we don't need to restore the base context info till the end. */
1049 switch (cx->cx_type) {
1052 continue; /* not break */
1070 die_where(char *message)
1075 register PERL_CONTEXT *cx;
1082 STRLEN klen = strlen(message);
1084 svp = hv_fetch(ERRHV, message, klen, TRUE);
1087 static char prefix[] = "\t(in cleanup) ";
1089 sv_upgrade(*svp, SVt_IV);
1090 (void)SvIOK_only(*svp);
1093 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1094 sv_catpvn(err, prefix, sizeof(prefix)-1);
1095 sv_catpvn(err, message, klen);
1101 sv_setpv(ERRSV, message);
1104 message = SvPVx(ERRSV, na);
1106 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
1114 if (cxix < cxstack_ix)
1118 if (cx->cx_type != CXt_EVAL) {
1119 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1124 if (gimme == G_SCALAR)
1125 *++newsp = &sv_undef;
1130 if (optype == OP_REQUIRE) {
1131 char* msg = SvPVx(ERRSV, na);
1132 DIE("%s", *msg ? msg : "Compilation failed in require");
1134 return pop_return();
1137 PerlIO_printf(PerlIO_stderr(), "%s",message);
1138 PerlIO_flush(PerlIO_stderr());
1147 if (SvTRUE(left) != SvTRUE(right))
1159 RETURNOP(cLOGOP->op_other);
1168 RETURNOP(cLOGOP->op_other);
1174 register I32 cxix = dopoptosub(cxstack_ix);
1175 register PERL_CONTEXT *cx;
1176 register PERL_CONTEXT *ccstack = cxstack;
1177 PERL_SI *top_si = curstackinfo;
1188 /* we may be in a higher stacklevel, so dig down deeper */
1189 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1190 top_si = top_si->si_prev;
1191 ccstack = top_si->si_cxstack;
1192 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1195 if (GIMME != G_ARRAY)
1199 if (DBsub && cxix >= 0 &&
1200 ccstack[cxix].blk_sub.cv == GvCV(DBsub))
1204 cxix = dopoptosub_at(ccstack, cxix - 1);
1207 cx = &ccstack[cxix];
1208 if (ccstack[cxix].cx_type == CXt_SUB) {
1209 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1210 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1211 field below is defined for any cx. */
1212 if (DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1213 cx = &ccstack[dbcxix];
1216 if (GIMME != G_ARRAY) {
1217 hv = cx->blk_oldcop->cop_stash;
1222 sv_setpv(TARG, HvNAME(hv));
1228 hv = cx->blk_oldcop->cop_stash;
1232 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1233 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1234 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1237 if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
1239 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1240 PUSHs(sv_2mortal(sv));
1241 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1244 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1245 PUSHs(sv_2mortal(newSViv(0)));
1247 gimme = (I32)cx->blk_gimme;
1248 if (gimme == G_VOID)
1251 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1252 if (cx->cx_type == CXt_EVAL) {
1253 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1254 PUSHs(cx->blk_eval.cur_text);
1257 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1258 /* Require, put the name. */
1259 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1263 else if (cx->cx_type == CXt_SUB &&
1264 cx->blk_sub.hasargs &&
1265 curcop->cop_stash == debstash)
1267 AV *ary = cx->blk_sub.argarray;
1268 int off = AvARRAY(ary) - AvALLOC(ary);
1272 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1275 AvREAL_off(dbargs); /* XXX Should be REIFY */
1278 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1279 av_extend(dbargs, AvFILLp(ary) + off);
1280 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1281 AvFILLp(dbargs) = AvFILLp(ary) + off;
1287 sortcv(SV *a, SV *b)
1290 I32 oldsaveix = savestack_ix;
1291 I32 oldscopeix = scopestack_ix;
1295 stack_sp = stack_base;
1298 if (stack_sp != stack_base + 1)
1299 croak("Sort subroutine didn't return single value");
1300 if (!SvNIOKp(*stack_sp))
1301 croak("Sort subroutine didn't return a numeric value");
1302 result = SvIV(*stack_sp);
1303 while (scopestack_ix > oldscopeix) {
1306 leave_scope(oldsaveix);
1319 sv_reset(tmps, curcop->cop_stash);
1332 TAINT_NOT; /* Each statement is presumed innocent */
1333 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1336 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1340 register PERL_CONTEXT *cx;
1341 I32 gimme = G_ARRAY;
1348 DIE("No DB::DB routine defined");
1350 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1362 push_return(op->op_next);
1363 PUSHBLOCK(cx, CXt_SUB, SP);
1366 (void)SvREFCNT_inc(cv);
1368 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1369 RETURNOP(CvSTART(cv));
1383 register PERL_CONTEXT *cx;
1384 I32 gimme = GIMME_V;
1391 if (op->op_flags & OPf_SPECIAL)
1392 svp = save_threadsv(op->op_targ); /* per-thread variable */
1394 #endif /* USE_THREADS */
1396 svp = &curpad[op->op_targ]; /* "my" variable */
1401 (void)save_scalar(gv);
1402 svp = &GvSV(gv); /* symbol table variable */
1407 PUSHBLOCK(cx, CXt_LOOP, SP);
1408 PUSHLOOP(cx, svp, MARK);
1409 if (op->op_flags & OPf_STACKED) {
1410 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1411 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1413 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1414 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1415 if (SvNV(sv) < IV_MIN ||
1416 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1417 croak("Range iterator outside integer range");
1418 cx->blk_loop.iterix = SvIV(sv);
1419 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1422 cx->blk_loop.iterlval = newSVsv(sv);
1426 cx->blk_loop.iterary = curstack;
1427 AvFILLp(curstack) = SP - stack_base;
1428 cx->blk_loop.iterix = MARK - stack_base;
1437 register PERL_CONTEXT *cx;
1438 I32 gimme = GIMME_V;
1444 PUSHBLOCK(cx, CXt_LOOP, SP);
1445 PUSHLOOP(cx, 0, SP);
1453 register PERL_CONTEXT *cx;
1454 struct block_loop cxloop;
1462 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1465 if (gimme == G_VOID)
1467 else if (gimme == G_SCALAR) {
1469 *++newsp = sv_mortalcopy(*SP);
1471 *++newsp = &sv_undef;
1475 *++newsp = sv_mortalcopy(*++mark);
1476 TAINT_NOT; /* Each item is independent */
1482 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1483 curpm = newpm; /* ... and pop $1 et al */
1495 register PERL_CONTEXT *cx;
1496 struct block_sub cxsub;
1497 bool popsub2 = FALSE;
1503 if (curstackinfo->si_type == PERLSI_SORT) {
1504 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1505 if (cxstack_ix > sortcxix)
1507 AvARRAY(curstack)[1] = *SP;
1508 stack_sp = stack_base + 1;
1513 cxix = dopoptosub(cxstack_ix);
1515 DIE("Can't return outside a subroutine");
1516 if (cxix < cxstack_ix)
1520 switch (cx->cx_type) {
1522 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1527 if (optype == OP_REQUIRE &&
1528 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1530 /* Unassume the success we assumed earlier. */
1531 char *name = cx->blk_eval.old_name;
1532 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1533 DIE("%s did not return a true value", name);
1537 DIE("panic: return");
1541 if (gimme == G_SCALAR) {
1544 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1546 *++newsp = SvREFCNT_inc(*SP);
1551 *++newsp = sv_mortalcopy(*SP);
1554 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1556 *++newsp = sv_mortalcopy(*SP);
1558 *++newsp = &sv_undef;
1560 else if (gimme == G_ARRAY) {
1561 while (++MARK <= SP) {
1562 *++newsp = (popsub2 && SvTEMP(*MARK))
1563 ? *MARK : sv_mortalcopy(*MARK);
1564 TAINT_NOT; /* Each item is independent */
1569 /* Stack values are safe: */
1571 POPSUB2(); /* release CV and @_ ... */
1573 curpm = newpm; /* ... and pop $1 et al */
1576 return pop_return();
1583 register PERL_CONTEXT *cx;
1584 struct block_loop cxloop;
1585 struct block_sub cxsub;
1592 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1594 if (op->op_flags & OPf_SPECIAL) {
1595 cxix = dopoptoloop(cxstack_ix);
1597 DIE("Can't \"last\" outside a block");
1600 cxix = dopoptolabel(cPVOP->op_pv);
1602 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1604 if (cxix < cxstack_ix)
1608 switch (cx->cx_type) {
1610 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1612 nextop = cxloop.last_op->op_next;
1615 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1617 nextop = pop_return();
1621 nextop = pop_return();
1628 if (gimme == G_SCALAR) {
1630 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1631 ? *SP : sv_mortalcopy(*SP);
1633 *++newsp = &sv_undef;
1635 else if (gimme == G_ARRAY) {
1636 while (++MARK <= SP) {
1637 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1638 ? *MARK : sv_mortalcopy(*MARK);
1639 TAINT_NOT; /* Each item is independent */
1645 /* Stack values are safe: */
1648 POPLOOP2(); /* release loop vars ... */
1652 POPSUB2(); /* release CV and @_ ... */
1655 curpm = newpm; /* ... and pop $1 et al */
1664 register PERL_CONTEXT *cx;
1667 if (op->op_flags & OPf_SPECIAL) {
1668 cxix = dopoptoloop(cxstack_ix);
1670 DIE("Can't \"next\" outside a block");
1673 cxix = dopoptolabel(cPVOP->op_pv);
1675 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1677 if (cxix < cxstack_ix)
1681 oldsave = scopestack[scopestack_ix - 1];
1682 LEAVE_SCOPE(oldsave);
1683 return cx->blk_loop.next_op;
1689 register PERL_CONTEXT *cx;
1692 if (op->op_flags & OPf_SPECIAL) {
1693 cxix = dopoptoloop(cxstack_ix);
1695 DIE("Can't \"redo\" outside a block");
1698 cxix = dopoptolabel(cPVOP->op_pv);
1700 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1702 if (cxix < cxstack_ix)
1706 oldsave = scopestack[scopestack_ix - 1];
1707 LEAVE_SCOPE(oldsave);
1708 return cx->blk_loop.redo_op;
1712 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1716 static char too_deep[] = "Target of goto is too deeply nested";
1720 if (o->op_type == OP_LEAVE ||
1721 o->op_type == OP_SCOPE ||
1722 o->op_type == OP_LEAVELOOP ||
1723 o->op_type == OP_LEAVETRY)
1725 *ops++ = cUNOPo->op_first;
1730 if (o->op_flags & OPf_KIDS) {
1732 /* First try all the kids at this level, since that's likeliest. */
1733 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1734 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1735 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1738 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1739 if (kid == lastgotoprobe)
1741 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1743 (ops[-1]->op_type != OP_NEXTSTATE &&
1744 ops[-1]->op_type != OP_DBSTATE)))
1746 if (o = dofindlabel(kid, label, ops, oplimit))
1756 return pp_goto(ARGS);
1765 register PERL_CONTEXT *cx;
1766 #define GOTO_DEPTH 64
1767 OP *enterops[GOTO_DEPTH];
1769 int do_dump = (op->op_type == OP_DUMP);
1772 if (op->op_flags & OPf_STACKED) {
1775 /* This egregious kludge implements goto &subroutine */
1776 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1778 register PERL_CONTEXT *cx;
1779 CV* cv = (CV*)SvRV(sv);
1784 if (!CvROOT(cv) && !CvXSUB(cv)) {
1786 SV *tmpstr = sv_newmortal();
1787 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1788 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1790 DIE("Goto undefined subroutine");
1793 /* First do some returnish stuff. */
1794 cxix = dopoptosub(cxstack_ix);
1796 DIE("Can't goto subroutine outside a subroutine");
1797 if (cxix < cxstack_ix)
1800 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1801 DIE("Can't goto subroutine from an eval-string");
1803 if (cx->cx_type == CXt_SUB &&
1804 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1805 AV* av = cx->blk_sub.argarray;
1807 items = AvFILLp(av) + 1;
1809 EXTEND(stack_sp, items); /* @_ could have been extended. */
1810 Copy(AvARRAY(av), stack_sp, items, SV*);
1813 SvREFCNT_dec(GvAV(defgv));
1814 GvAV(defgv) = cx->blk_sub.savearray;
1815 #endif /* USE_THREADS */
1819 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1823 av = (AV*)curpad[0];
1827 items = AvFILLp(av) + 1;
1829 EXTEND(stack_sp, items); /* @_ could have been extended. */
1830 Copy(AvARRAY(av), stack_sp, items, SV*);
1833 if (cx->cx_type == CXt_SUB &&
1834 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1835 SvREFCNT_dec(cx->blk_sub.cv);
1836 oldsave = scopestack[scopestack_ix - 1];
1837 LEAVE_SCOPE(oldsave);
1839 /* Now do some callish stuff. */
1842 if (CvOLDSTYLE(cv)) {
1843 I32 (*fp3)_((int,int,int));
1848 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1849 items = (*fp3)(CvXSUBANY(cv).any_i32,
1850 mark - stack_base + 1,
1852 SP = stack_base + items;
1858 stack_sp--; /* There is no cv arg. */
1859 /* Push a mark for the start of arglist */
1861 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1862 /* Pop the current context like a decent sub should */
1863 POPBLOCK(cx, curpm);
1864 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1867 return pop_return();
1870 AV* padlist = CvPADLIST(cv);
1871 SV** svp = AvARRAY(padlist);
1872 if (cx->cx_type == CXt_EVAL) {
1873 in_eval = cx->blk_eval.old_in_eval;
1874 eval_root = cx->blk_eval.old_eval_root;
1875 cx->cx_type = CXt_SUB;
1876 cx->blk_sub.hasargs = 0;
1878 cx->blk_sub.cv = cv;
1879 cx->blk_sub.olddepth = CvDEPTH(cv);
1881 if (CvDEPTH(cv) < 2)
1882 (void)SvREFCNT_inc(cv);
1883 else { /* save temporaries on recursion? */
1884 if (CvDEPTH(cv) == 100 && dowarn)
1885 sub_crush_depth(cv);
1886 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1887 AV *newpad = newAV();
1888 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1889 I32 ix = AvFILLp((AV*)svp[1]);
1890 svp = AvARRAY(svp[0]);
1891 for ( ;ix > 0; ix--) {
1892 if (svp[ix] != &sv_undef) {
1893 char *name = SvPVX(svp[ix]);
1894 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1897 /* outer lexical or anon code */
1898 av_store(newpad, ix,
1899 SvREFCNT_inc(oldpad[ix]) );
1901 else { /* our own lexical */
1903 av_store(newpad, ix, sv = (SV*)newAV());
1904 else if (*name == '%')
1905 av_store(newpad, ix, sv = (SV*)newHV());
1907 av_store(newpad, ix, sv = NEWSV(0,0));
1912 av_store(newpad, ix, sv = NEWSV(0,0));
1916 if (cx->blk_sub.hasargs) {
1919 av_store(newpad, 0, (SV*)av);
1920 AvFLAGS(av) = AVf_REIFY;
1922 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1923 AvFILLp(padlist) = CvDEPTH(cv);
1924 svp = AvARRAY(padlist);
1928 if (!cx->blk_sub.hasargs) {
1929 AV* av = (AV*)curpad[0];
1931 items = AvFILLp(av) + 1;
1933 /* Mark is at the end of the stack. */
1935 Copy(AvARRAY(av), SP + 1, items, SV*);
1940 #endif /* USE_THREADS */
1942 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1944 if (cx->blk_sub.hasargs)
1945 #endif /* USE_THREADS */
1947 AV* av = (AV*)curpad[0];
1951 cx->blk_sub.savearray = GvAV(defgv);
1952 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1953 #endif /* USE_THREADS */
1954 cx->blk_sub.argarray = av;
1957 if (items >= AvMAX(av) + 1) {
1959 if (AvARRAY(av) != ary) {
1960 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1961 SvPVX(av) = (char*)ary;
1963 if (items >= AvMAX(av) + 1) {
1964 AvMAX(av) = items - 1;
1965 Renew(ary,items+1,SV*);
1967 SvPVX(av) = (char*)ary;
1970 Copy(mark,AvARRAY(av),items,SV*);
1971 AvFILLp(av) = items - 1;
1979 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1981 * We do not care about using sv to call CV;
1982 * it's for informational purposes only.
1984 SV *sv = GvSV(DBsub);
1987 if (PERLDB_SUB_NN) {
1988 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1991 gv_efullname3(sv, CvGV(cv), Nullch);
1994 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1995 PUSHMARK( stack_sp );
1996 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2000 RETURNOP(CvSTART(cv));
2004 label = SvPV(sv,na);
2006 else if (op->op_flags & OPf_SPECIAL) {
2008 DIE("goto must have label");
2011 label = cPVOP->op_pv;
2013 if (label && *label) {
2020 for (ix = cxstack_ix; ix >= 0; ix--) {
2022 switch (cx->cx_type) {
2024 gotoprobe = eval_root; /* XXX not good for nested eval */
2027 gotoprobe = cx->blk_oldcop->op_sibling;
2033 gotoprobe = cx->blk_oldcop->op_sibling;
2035 gotoprobe = main_root;
2038 if (CvDEPTH(cx->blk_sub.cv)) {
2039 gotoprobe = CvROOT(cx->blk_sub.cv);
2044 DIE("Can't \"goto\" outside a block");
2048 gotoprobe = main_root;
2051 retop = dofindlabel(gotoprobe, label,
2052 enterops, enterops + GOTO_DEPTH);
2055 lastgotoprobe = gotoprobe;
2058 DIE("Can't find label %s", label);
2060 /* pop unwanted frames */
2062 if (ix < cxstack_ix) {
2069 oldsave = scopestack[scopestack_ix];
2070 LEAVE_SCOPE(oldsave);
2073 /* push wanted frames */
2075 if (*enterops && enterops[1]) {
2077 for (ix = 1; enterops[ix]; ix++) {
2079 /* Eventually we may want to stack the needed arguments
2080 * for each op. For now, we punt on the hard ones. */
2081 if (op->op_type == OP_ENTERITER)
2082 DIE("Can't \"goto\" into the middle of a foreach loop",
2084 (CALLOP->op_ppaddr)(ARGS);
2092 if (!retop) retop = main_start;
2099 restartop = 0; /* hmm, must be GNU unexec().. */
2103 if (top_env->je_prev) {
2121 if (anum == 1 && VMSISH_EXIT)
2134 double value = SvNVx(GvSV(cCOP->cop_gv));
2135 register I32 match = I_32(value);
2138 if (((double)match) > value)
2139 --match; /* was fractional--truncate other way */
2141 match -= cCOP->uop.scop.scop_offset;
2144 else if (match > cCOP->uop.scop.scop_max)
2145 match = cCOP->uop.scop.scop_max;
2146 op = cCOP->uop.scop.scop_next[match];
2156 op = op->op_next; /* can't assume anything */
2158 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2159 match -= cCOP->uop.scop.scop_offset;
2162 else if (match > cCOP->uop.scop.scop_max)
2163 match = cCOP->uop.scop.scop_max;
2164 op = cCOP->uop.scop.scop_next[match];
2173 save_lines(AV *array, SV *sv)
2175 register char *s = SvPVX(sv);
2176 register char *send = SvPVX(sv) + SvCUR(sv);
2178 register I32 line = 1;
2180 while (s && s < send) {
2181 SV *tmpstr = NEWSV(85,0);
2183 sv_upgrade(tmpstr, SVt_PVMG);
2184 t = strchr(s, '\n');
2190 sv_setpvn(tmpstr, s, t - s);
2191 av_store(array, line++, tmpstr);
2206 assert(CATCH_GET == TRUE);
2207 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2211 default: /* topmost level handles it */
2218 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2234 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2235 /* sv Text to convert to OP tree. */
2236 /* startop op_free() this to undo. */
2237 /* code Short string id of the caller. */
2239 dSP; /* Make POPBLOCK work. */
2242 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2246 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2252 /* switch to eval mode */
2254 SAVESPTR(compiling.cop_filegv);
2255 SAVEI16(compiling.cop_line);
2256 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2257 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2258 compiling.cop_line = 1;
2259 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2260 deleting the eval's FILEGV from the stash before gv_check() runs
2261 (i.e. before run-time proper). To work around the coredump that
2262 ensues, we always turn GvMULTI_on for any globals that were
2263 introduced within evals. See force_ident(). GSAR 96-10-12 */
2264 safestr = savepv(tmpbuf);
2265 SAVEDELETE(defstash, safestr, strlen(safestr));
2267 #ifdef OP_IN_REGISTER
2275 op->op_type = 0; /* Avoid uninit warning. */
2276 op->op_flags = 0; /* Avoid uninit warning. */
2277 PUSHBLOCK(cx, CXt_EVAL, SP);
2278 PUSHEVAL(cx, 0, compiling.cop_filegv);
2279 rop = doeval(G_SCALAR, startop);
2283 (*startop)->op_type = OP_NULL;
2284 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2286 *avp = (AV*)SvREFCNT_inc(comppad);
2288 #ifdef OP_IN_REGISTER
2294 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2296 doeval(int gimme, OP** startop)
2309 /* set up a scratch pad */
2314 SAVESPTR(comppad_name);
2315 SAVEI32(comppad_name_fill);
2316 SAVEI32(min_intro_pending);
2317 SAVEI32(max_intro_pending);
2320 for (i = cxstack_ix - 1; i >= 0; i--) {
2321 PERL_CONTEXT *cx = &cxstack[i];
2322 if (cx->cx_type == CXt_EVAL)
2324 else if (cx->cx_type == CXt_SUB) {
2325 caller = cx->blk_sub.cv;
2331 compcv = (CV*)NEWSV(1104,0);
2332 sv_upgrade((SV *)compcv, SVt_PVCV);
2333 CvUNIQUE_on(compcv);
2335 CvOWNER(compcv) = 0;
2336 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2337 MUTEX_INIT(CvMUTEXP(compcv));
2338 #endif /* USE_THREADS */
2341 av_push(comppad, Nullsv);
2342 curpad = AvARRAY(comppad);
2343 comppad_name = newAV();
2344 comppad_name_fill = 0;
2345 min_intro_pending = 0;
2348 av_store(comppad_name, 0, newSVpv("@_", 2));
2349 curpad[0] = (SV*)newAV();
2350 SvPADMY_on(curpad[0]); /* XXX Needed? */
2351 #endif /* USE_THREADS */
2353 comppadlist = newAV();
2354 AvREAL_off(comppadlist);
2355 av_store(comppadlist, 0, (SV*)comppad_name);
2356 av_store(comppadlist, 1, (SV*)comppad);
2357 CvPADLIST(compcv) = comppadlist;
2359 if (!saveop || saveop->op_type != OP_REQUIRE)
2360 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2364 /* make sure we compile in the right package */
2366 newstash = curcop->cop_stash;
2367 if (curstash != newstash) {
2369 curstash = newstash;
2373 SAVEFREESV(beginav);
2375 /* try to compile it */
2379 curcop = &compiling;
2380 curcop->cop_arybase = 0;
2382 rs = newSVpv("\n", 1);
2383 if (saveop && saveop->op_flags & OPf_SPECIAL)
2387 if (yyparse() || error_count || !eval_root) {
2391 I32 optype = 0; /* Might be reset by POPEVAL. */
2398 SP = stack_base + POPMARK; /* pop original mark */
2406 if (optype == OP_REQUIRE) {
2407 char* msg = SvPVx(ERRSV, na);
2408 DIE("%s", *msg ? msg : "Compilation failed in require");
2409 } else if (startop) {
2410 char* msg = SvPVx(ERRSV, na);
2414 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2417 rs = SvREFCNT_inc(nrs);
2419 MUTEX_LOCK(&eval_mutex);
2421 COND_SIGNAL(&eval_cond);
2422 MUTEX_UNLOCK(&eval_mutex);
2423 #endif /* USE_THREADS */
2427 rs = SvREFCNT_inc(nrs);
2428 compiling.cop_line = 0;
2430 *startop = eval_root;
2431 SvREFCNT_dec(CvOUTSIDE(compcv));
2432 CvOUTSIDE(compcv) = Nullcv;
2434 SAVEFREEOP(eval_root);
2436 scalarvoid(eval_root);
2437 else if (gimme & G_ARRAY)
2442 DEBUG_x(dump_eval());
2444 /* Register with debugger: */
2445 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2446 CV *cv = perl_get_cv("DB::postponed", FALSE);
2450 XPUSHs((SV*)compiling.cop_filegv);
2452 perl_call_sv((SV*)cv, G_DISCARD);
2456 /* compiled okay, so do it */
2458 CvDEPTH(compcv) = 1;
2459 SP = stack_base + POPMARK; /* pop original mark */
2460 op = saveop; /* The caller may need it. */
2462 MUTEX_LOCK(&eval_mutex);
2464 COND_SIGNAL(&eval_cond);
2465 MUTEX_UNLOCK(&eval_mutex);
2466 #endif /* USE_THREADS */
2468 RETURNOP(eval_start);
2474 register PERL_CONTEXT *cx;
2479 SV *namesv = Nullsv;
2481 I32 gimme = G_SCALAR;
2482 PerlIO *tryrsfp = 0;
2485 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2486 SET_NUMERIC_STANDARD();
2487 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2488 DIE("Perl %s required--this is only version %s, stopped",
2489 SvPV(sv,na),patchlevel);
2492 name = SvPV(sv, len);
2493 if (!(name && len > 0 && *name))
2494 DIE("Null filename used");
2495 TAINT_PROPER("require");
2496 if (op->op_type == OP_REQUIRE &&
2497 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2501 /* prepare to compile file */
2506 (name[1] == '.' && name[2] == '/')))
2508 || (name[0] && name[1] == ':')
2511 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2514 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2515 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2520 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2523 AV *ar = GvAVn(incgv);
2527 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2530 namesv = NEWSV(806, 0);
2531 for (i = 0; i <= AvFILL(ar); i++) {
2532 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2535 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2537 sv_setpv(namesv, unixdir);
2538 sv_catpv(namesv, unixname);
2540 sv_setpvf(namesv, "%s/%s", dir, name);
2542 tryname = SvPVX(namesv);
2543 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2545 if (tryname[0] == '.' && tryname[1] == '/')
2552 SAVESPTR(compiling.cop_filegv);
2553 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2554 SvREFCNT_dec(namesv);
2556 if (op->op_type == OP_REQUIRE) {
2557 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2558 SV *dirmsgsv = NEWSV(0, 0);
2559 AV *ar = GvAVn(incgv);
2561 if (instr(SvPVX(msg), ".h "))
2562 sv_catpv(msg, " (change .h to .ph maybe?)");
2563 if (instr(SvPVX(msg), ".ph "))
2564 sv_catpv(msg, " (did you run h2ph?)");
2565 sv_catpv(msg, " (@INC contains:");
2566 for (i = 0; i <= AvFILL(ar); i++) {
2567 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2568 sv_setpvf(dirmsgsv, " %s", dir);
2569 sv_catsv(msg, dirmsgsv);
2571 sv_catpvn(msg, ")", 1);
2572 SvREFCNT_dec(dirmsgsv);
2579 /* Assume success here to prevent recursive requirement. */
2580 (void)hv_store(GvHVn(incgv), name, strlen(name),
2581 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2585 lex_start(sv_2mortal(newSVpv("",0)));
2587 save_aptr(&rsfp_filters);
2588 rsfp_filters = NULL;
2592 name = savepv(name);
2597 /* switch to eval mode */
2599 push_return(op->op_next);
2600 PUSHBLOCK(cx, CXt_EVAL, SP);
2601 PUSHEVAL(cx, name, compiling.cop_filegv);
2603 compiling.cop_line = 0;
2607 MUTEX_LOCK(&eval_mutex);
2608 if (eval_owner && eval_owner != thr)
2610 COND_WAIT(&eval_cond, &eval_mutex);
2612 MUTEX_UNLOCK(&eval_mutex);
2613 #endif /* USE_THREADS */
2614 return DOCATCH(doeval(G_SCALAR, NULL));
2619 return pp_require(ARGS);
2625 register PERL_CONTEXT *cx;
2627 I32 gimme = GIMME_V, was = sub_generation;
2628 char tmpbuf[TYPE_DIGITS(long) + 12];
2633 if (!SvPV(sv,len) || !len)
2635 TAINT_PROPER("eval");
2641 /* switch to eval mode */
2643 SAVESPTR(compiling.cop_filegv);
2644 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2645 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2646 compiling.cop_line = 1;
2647 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2648 deleting the eval's FILEGV from the stash before gv_check() runs
2649 (i.e. before run-time proper). To work around the coredump that
2650 ensues, we always turn GvMULTI_on for any globals that were
2651 introduced within evals. See force_ident(). GSAR 96-10-12 */
2652 safestr = savepv(tmpbuf);
2653 SAVEDELETE(defstash, safestr, strlen(safestr));
2655 hints = op->op_targ;
2657 push_return(op->op_next);
2658 PUSHBLOCK(cx, CXt_EVAL, SP);
2659 PUSHEVAL(cx, 0, compiling.cop_filegv);
2661 /* prepare to compile string */
2663 if (PERLDB_LINE && curstash != debstash)
2664 save_lines(GvAV(compiling.cop_filegv), linestr);
2667 MUTEX_LOCK(&eval_mutex);
2668 if (eval_owner && eval_owner != thr)
2670 COND_WAIT(&eval_cond, &eval_mutex);
2672 MUTEX_UNLOCK(&eval_mutex);
2673 #endif /* USE_THREADS */
2674 ret = doeval(gimme, NULL);
2675 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2676 && ret != op->op_next) { /* Successive compilation. */
2677 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2679 return DOCATCH(ret);
2689 register PERL_CONTEXT *cx;
2691 U8 save_flags = op -> op_flags;
2696 retop = pop_return();
2699 if (gimme == G_VOID)
2701 else if (gimme == G_SCALAR) {
2704 if (SvFLAGS(TOPs) & SVs_TEMP)
2707 *MARK = sv_mortalcopy(TOPs);
2715 /* in case LEAVE wipes old return values */
2716 for (mark = newsp + 1; mark <= SP; mark++) {
2717 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2718 *mark = sv_mortalcopy(*mark);
2719 TAINT_NOT; /* Each item is independent */
2723 curpm = newpm; /* Don't pop $1 et al till now */
2726 * Closures mentioned at top level of eval cannot be referenced
2727 * again, and their presence indirectly causes a memory leak.
2728 * (Note that the fact that compcv and friends are still set here
2729 * is, AFAIK, an accident.) --Chip
2731 if (AvFILLp(comppad_name) >= 0) {
2732 SV **svp = AvARRAY(comppad_name);
2734 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2736 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2738 svp[ix] = &sv_undef;
2742 SvREFCNT_dec(CvOUTSIDE(sv));
2743 CvOUTSIDE(sv) = Nullcv;
2756 assert(CvDEPTH(compcv) == 1);
2758 CvDEPTH(compcv) = 0;
2761 if (optype == OP_REQUIRE &&
2762 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2764 /* Unassume the success we assumed earlier. */
2765 char *name = cx->blk_eval.old_name;
2766 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2767 retop = die("%s did not return a true value", name);
2768 /* die_where() did LEAVE, or we won't be here */
2772 if (!(save_flags & OPf_SPECIAL))
2782 register PERL_CONTEXT *cx;
2783 I32 gimme = GIMME_V;
2788 push_return(cLOGOP->op_other->op_next);
2789 PUSHBLOCK(cx, CXt_EVAL, SP);
2791 eval_root = op; /* Only needed so that goto works right. */
2796 return DOCATCH(op->op_next);
2806 register PERL_CONTEXT *cx;
2814 if (gimme == G_VOID)
2816 else if (gimme == G_SCALAR) {
2819 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2822 *MARK = sv_mortalcopy(TOPs);
2831 /* in case LEAVE wipes old return values */
2832 for (mark = newsp + 1; mark <= SP; mark++) {
2833 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2834 *mark = sv_mortalcopy(*mark);
2835 TAINT_NOT; /* Each item is independent */
2839 curpm = newpm; /* Don't pop $1 et al till now */
2850 register char *s = SvPV_force(sv, len);
2851 register char *send = s + len;
2852 register char *base;
2853 register I32 skipspaces = 0;
2856 bool postspace = FALSE;
2864 croak("Null picture in formline");
2866 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2871 *fpc++ = FF_LINEMARK;
2872 noblank = repeat = FALSE;
2890 case ' ': case '\t':
2901 *fpc++ = FF_LITERAL;
2909 *fpc++ = skipspaces;
2913 *fpc++ = FF_NEWLINE;
2917 arg = fpc - linepc + 1;
2924 *fpc++ = FF_LINEMARK;
2925 noblank = repeat = FALSE;
2934 ischop = s[-1] == '^';
2940 arg = (s - base) - 1;
2942 *fpc++ = FF_LITERAL;
2951 *fpc++ = FF_LINEGLOB;
2953 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2954 arg = ischop ? 512 : 0;
2964 arg |= 256 + (s - f);
2966 *fpc++ = s - base; /* fieldsize for FETCH */
2967 *fpc++ = FF_DECIMAL;
2972 bool ismore = FALSE;
2975 while (*++s == '>') ;
2976 prespace = FF_SPACE;
2978 else if (*s == '|') {
2979 while (*++s == '|') ;
2980 prespace = FF_HALFSPACE;
2985 while (*++s == '<') ;
2988 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2992 *fpc++ = s - base; /* fieldsize for FETCH */
2994 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3012 { /* need to jump to the next word */
3014 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3015 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3016 s = SvPVX(sv) + SvCUR(sv) + z;
3018 Copy(fops, s, arg, U16);
3020 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3025 * The rest of this file was derived from source code contributed
3028 * NOTE: this code was derived from Tom Horsley's qsort replacement
3029 * and should not be confused with the original code.
3032 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3034 Permission granted to distribute under the same terms as perl which are
3037 This program is free software; you can redistribute it and/or modify
3038 it under the terms of either:
3040 a) the GNU General Public License as published by the Free
3041 Software Foundation; either version 1, or (at your option) any
3044 b) the "Artistic License" which comes with this Kit.
3046 Details on the perl license can be found in the perl source code which
3047 may be located via the www.perl.com web page.
3049 This is the most wonderfulest possible qsort I can come up with (and
3050 still be mostly portable) My (limited) tests indicate it consistently
3051 does about 20% fewer calls to compare than does the qsort in the Visual
3052 C++ library, other vendors may vary.
3054 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3055 others I invented myself (or more likely re-invented since they seemed
3056 pretty obvious once I watched the algorithm operate for a while).
3058 Most of this code was written while watching the Marlins sweep the Giants
3059 in the 1997 National League Playoffs - no Braves fans allowed to use this
3060 code (just kidding :-).
3062 I realize that if I wanted to be true to the perl tradition, the only
3063 comment in this file would be something like:
3065 ...they shuffled back towards the rear of the line. 'No, not at the
3066 rear!' the slave-driver shouted. 'Three files up. And stay there...
3068 However, I really needed to violate that tradition just so I could keep
3069 track of what happens myself, not to mention some poor fool trying to
3070 understand this years from now :-).
3073 /* ********************************************************** Configuration */
3075 #ifndef QSORT_ORDER_GUESS
3076 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3079 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3080 future processing - a good max upper bound is log base 2 of memory size
3081 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3082 safely be smaller than that since the program is taking up some space and
3083 most operating systems only let you grab some subset of contiguous
3084 memory (not to mention that you are normally sorting data larger than
3085 1 byte element size :-).
3087 #ifndef QSORT_MAX_STACK
3088 #define QSORT_MAX_STACK 32
3091 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3092 Anything bigger and we use qsort. If you make this too small, the qsort
3093 will probably break (or become less efficient), because it doesn't expect
3094 the middle element of a partition to be the same as the right or left -
3095 you have been warned).
3097 #ifndef QSORT_BREAK_EVEN
3098 #define QSORT_BREAK_EVEN 6
3101 /* ************************************************************* Data Types */
3103 /* hold left and right index values of a partition waiting to be sorted (the
3104 partition includes both left and right - right is NOT one past the end or
3105 anything like that).
3107 struct partition_stack_entry {
3110 #ifdef QSORT_ORDER_GUESS
3111 int qsort_break_even;
3115 /* ******************************************************* Shorthand Macros */
3117 /* Note that these macros will be used from inside the qsort function where
3118 we happen to know that the variable 'elt_size' contains the size of an
3119 array element and the variable 'temp' points to enough space to hold a
3120 temp element and the variable 'array' points to the array being sorted
3121 and 'compare' is the pointer to the compare routine.
3123 Also note that there are very many highly architecture specific ways
3124 these might be sped up, but this is simply the most generally portable
3125 code I could think of.
3128 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3131 #define qsort_cmp(elt1, elt2) \
3132 ((this->*compare)(array[elt1], array[elt2]))
3134 #define qsort_cmp(elt1, elt2) \
3135 ((*compare)(array[elt1], array[elt2]))
3138 #ifdef QSORT_ORDER_GUESS
3139 #define QSORT_NOTICE_SWAP swapped++;
3141 #define QSORT_NOTICE_SWAP
3144 /* swaps contents of array elements elt1, elt2.
3146 #define qsort_swap(elt1, elt2) \
3149 temp = array[elt1]; \
3150 array[elt1] = array[elt2]; \
3151 array[elt2] = temp; \
3154 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3155 elt3 and elt3 gets elt1.
3157 #define qsort_rotate(elt1, elt2, elt3) \
3160 temp = array[elt1]; \
3161 array[elt1] = array[elt2]; \
3162 array[elt2] = array[elt3]; \
3163 array[elt3] = temp; \
3166 /* ************************************************************ Debug stuff */
3173 return; /* good place to set a breakpoint */
3176 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3179 doqsort_all_asserts(
3183 int (*compare)(const void * elt1, const void * elt2),
3184 int pc_left, int pc_right, int u_left, int u_right)
3188 qsort_assert(pc_left <= pc_right);
3189 qsort_assert(u_right < pc_left);
3190 qsort_assert(pc_right < u_left);
3191 for (i = u_right + 1; i < pc_left; ++i) {
3192 qsort_assert(qsort_cmp(i, pc_left) < 0);
3194 for (i = pc_left; i < pc_right; ++i) {
3195 qsort_assert(qsort_cmp(i, pc_right) == 0);
3197 for (i = pc_right + 1; i < u_left; ++i) {
3198 qsort_assert(qsort_cmp(pc_right, i) < 0);
3202 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3203 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3204 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3208 #define qsort_assert(t) ((void)0)
3210 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3214 /* ****************************************************************** qsort */
3218 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3223 I32 (*compare)(SV *a, SV *b))
3228 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3229 int next_stack_entry = 0;
3233 #ifdef QSORT_ORDER_GUESS
3234 int qsort_break_even;
3238 /* Make sure we actually have work to do.
3240 if (num_elts <= 1) {
3244 /* Setup the initial partition definition and fall into the sorting loop
3247 part_right = (int)(num_elts - 1);
3248 #ifdef QSORT_ORDER_GUESS
3249 qsort_break_even = QSORT_BREAK_EVEN;
3251 #define qsort_break_even QSORT_BREAK_EVEN
3254 if ((part_right - part_left) >= qsort_break_even) {
3255 /* OK, this is gonna get hairy, so lets try to document all the
3256 concepts and abbreviations and variables and what they keep
3259 pc: pivot chunk - the set of array elements we accumulate in the
3260 middle of the partition, all equal in value to the original
3261 pivot element selected. The pc is defined by:
3263 pc_left - the leftmost array index of the pc
3264 pc_right - the rightmost array index of the pc
3266 we start with pc_left == pc_right and only one element
3267 in the pivot chunk (but it can grow during the scan).
3269 u: uncompared elements - the set of elements in the partition
3270 we have not yet compared to the pivot value. There are two
3271 uncompared sets during the scan - one to the left of the pc
3272 and one to the right.
3274 u_right - the rightmost index of the left side's uncompared set
3275 u_left - the leftmost index of the right side's uncompared set
3277 The leftmost index of the left sides's uncompared set
3278 doesn't need its own variable because it is always defined
3279 by the leftmost edge of the whole partition (part_left). The
3280 same goes for the rightmost edge of the right partition
3283 We know there are no uncompared elements on the left once we
3284 get u_right < part_left and no uncompared elements on the
3285 right once u_left > part_right. When both these conditions
3286 are met, we have completed the scan of the partition.
3288 Any elements which are between the pivot chunk and the
3289 uncompared elements should be less than the pivot value on
3290 the left side and greater than the pivot value on the right
3291 side (in fact, the goal of the whole algorithm is to arrange
3292 for that to be true and make the groups of less-than and
3293 greater-then elements into new partitions to sort again).
3295 As you marvel at the complexity of the code and wonder why it
3296 has to be so confusing. Consider some of the things this level
3297 of confusion brings:
3299 Once I do a compare, I squeeze every ounce of juice out of it. I
3300 never do compare calls I don't have to do, and I certainly never
3303 I also never swap any elements unless I can prove there is a
3304 good reason. Many sort algorithms will swap a known value with
3305 an uncompared value just to get things in the right place (or
3306 avoid complexity :-), but that uncompared value, once it gets
3307 compared, may then have to be swapped again. A lot of the
3308 complexity of this code is due to the fact that it never swaps
3309 anything except compared values, and it only swaps them when the
3310 compare shows they are out of position.
3312 int pc_left, pc_right;
3313 int u_right, u_left;
3317 pc_left = ((part_left + part_right) / 2);
3319 u_right = pc_left - 1;
3320 u_left = pc_right + 1;
3322 /* Qsort works best when the pivot value is also the median value
3323 in the partition (unfortunately you can't find the median value
3324 without first sorting :-), so to give the algorithm a helping
3325 hand, we pick 3 elements and sort them and use the median value
3326 of that tiny set as the pivot value.
3328 Some versions of qsort like to use the left middle and right as
3329 the 3 elements to sort so they can insure the ends of the
3330 partition will contain values which will stop the scan in the
3331 compare loop, but when you have to call an arbitrarily complex
3332 routine to do a compare, its really better to just keep track of
3333 array index values to know when you hit the edge of the
3334 partition and avoid the extra compare. An even better reason to
3335 avoid using a compare call is the fact that you can drop off the
3336 edge of the array if someone foolishly provides you with an
3337 unstable compare function that doesn't always provide consistent
3340 So, since it is simpler for us to compare the three adjacent
3341 elements in the middle of the partition, those are the ones we
3342 pick here (conveniently pointed at by u_right, pc_left, and
3343 u_left). The values of the left, center, and right elements
3344 are refered to as l c and r in the following comments.
3347 #ifdef QSORT_ORDER_GUESS
3350 s = qsort_cmp(u_right, pc_left);
3353 s = qsort_cmp(pc_left, u_left);
3354 /* if l < c, c < r - already in order - nothing to do */
3356 /* l < c, c == r - already in order, pc grows */
3358 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3360 /* l < c, c > r - need to know more */
3361 s = qsort_cmp(u_right, u_left);
3363 /* l < c, c > r, l < r - swap c & r to get ordered */
3364 qsort_swap(pc_left, u_left);
3365 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3366 } else if (s == 0) {
3367 /* l < c, c > r, l == r - swap c&r, grow pc */
3368 qsort_swap(pc_left, u_left);
3370 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3372 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3373 qsort_rotate(pc_left, u_right, u_left);
3374 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3377 } else if (s == 0) {
3379 s = qsort_cmp(pc_left, u_left);
3381 /* l == c, c < r - already in order, grow pc */
3383 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3384 } else if (s == 0) {
3385 /* l == c, c == r - already in order, grow pc both ways */
3388 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3390 /* l == c, c > r - swap l & r, grow pc */
3391 qsort_swap(u_right, u_left);
3393 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3397 s = qsort_cmp(pc_left, u_left);
3399 /* l > c, c < r - need to know more */
3400 s = qsort_cmp(u_right, u_left);
3402 /* l > c, c < r, l < r - swap l & c to get ordered */
3403 qsort_swap(u_right, pc_left);
3404 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3405 } else if (s == 0) {
3406 /* l > c, c < r, l == r - swap l & c, grow pc */
3407 qsort_swap(u_right, pc_left);
3409 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3411 /* l > c, c < r, l > r - rotate lcr into crl to order */
3412 qsort_rotate(u_right, pc_left, u_left);
3413 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3415 } else if (s == 0) {
3416 /* l > c, c == r - swap ends, grow pc */
3417 qsort_swap(u_right, u_left);
3419 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3421 /* l > c, c > r - swap ends to get in order */
3422 qsort_swap(u_right, u_left);
3423 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3426 /* We now know the 3 middle elements have been compared and
3427 arranged in the desired order, so we can shrink the uncompared
3432 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3434 /* The above massive nested if was the simple part :-). We now have
3435 the middle 3 elements ordered and we need to scan through the
3436 uncompared sets on either side, swapping elements that are on
3437 the wrong side or simply shuffling equal elements around to get
3438 all equal elements into the pivot chunk.
3442 int still_work_on_left;
3443 int still_work_on_right;
3445 /* Scan the uncompared values on the left. If I find a value
3446 equal to the pivot value, move it over so it is adjacent to
3447 the pivot chunk and expand the pivot chunk. If I find a value
3448 less than the pivot value, then just leave it - its already
3449 on the correct side of the partition. If I find a greater
3450 value, then stop the scan.
3452 while (still_work_on_left = (u_right >= part_left)) {
3453 s = qsort_cmp(u_right, pc_left);
3456 } else if (s == 0) {
3458 if (pc_left != u_right) {
3459 qsort_swap(u_right, pc_left);
3465 qsort_assert(u_right < pc_left);
3466 qsort_assert(pc_left <= pc_right);
3467 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3468 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3471 /* Do a mirror image scan of uncompared values on the right
3473 while (still_work_on_right = (u_left <= part_right)) {
3474 s = qsort_cmp(pc_right, u_left);
3477 } else if (s == 0) {
3479 if (pc_right != u_left) {
3480 qsort_swap(pc_right, u_left);
3486 qsort_assert(u_left > pc_right);
3487 qsort_assert(pc_left <= pc_right);
3488 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3489 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3492 if (still_work_on_left) {
3493 /* I know I have a value on the left side which needs to be
3494 on the right side, but I need to know more to decide
3495 exactly the best thing to do with it.
3497 if (still_work_on_right) {
3498 /* I know I have values on both side which are out of
3499 position. This is a big win because I kill two birds
3500 with one swap (so to speak). I can advance the
3501 uncompared pointers on both sides after swapping both
3502 of them into the right place.
3504 qsort_swap(u_right, u_left);
3507 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3509 /* I have an out of position value on the left, but the
3510 right is fully scanned, so I "slide" the pivot chunk
3511 and any less-than values left one to make room for the
3512 greater value over on the right. If the out of position
3513 value is immediately adjacent to the pivot chunk (there
3514 are no less-than values), I can do that with a swap,
3515 otherwise, I have to rotate one of the less than values
3516 into the former position of the out of position value
3517 and the right end of the pivot chunk into the left end
3521 if (pc_left == u_right) {
3522 qsort_swap(u_right, pc_right);
3523 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3525 qsort_rotate(u_right, pc_left, pc_right);
3526 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3531 } else if (still_work_on_right) {
3532 /* Mirror image of complex case above: I have an out of
3533 position value on the right, but the left is fully
3534 scanned, so I need to shuffle things around to make room
3535 for the right value on the left.
3538 if (pc_right == u_left) {
3539 qsort_swap(u_left, pc_left);
3540 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3542 qsort_rotate(pc_right, pc_left, u_left);
3543 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3548 /* No more scanning required on either side of partition,
3549 break out of loop and figure out next set of partitions
3555 /* The elements in the pivot chunk are now in the right place. They
3556 will never move or be compared again. All I have to do is decide
3557 what to do with the stuff to the left and right of the pivot
3560 Notes on the QSORT_ORDER_GUESS ifdef code:
3562 1. If I just built these partitions without swapping any (or
3563 very many) elements, there is a chance that the elements are
3564 already ordered properly (being properly ordered will
3565 certainly result in no swapping, but the converse can't be
3568 2. A (properly written) insertion sort will run faster on
3569 already ordered data than qsort will.
3571 3. Perhaps there is some way to make a good guess about
3572 switching to an insertion sort earlier than partition size 6
3573 (for instance - we could save the partition size on the stack
3574 and increase the size each time we find we didn't swap, thus
3575 switching to insertion sort earlier for partitions with a
3576 history of not swapping).
3578 4. Naturally, if I just switch right away, it will make
3579 artificial benchmarks with pure ascending (or descending)
3580 data look really good, but is that a good reason in general?
3584 #ifdef QSORT_ORDER_GUESS
3586 #if QSORT_ORDER_GUESS == 1
3587 qsort_break_even = (part_right - part_left) + 1;
3589 #if QSORT_ORDER_GUESS == 2
3590 qsort_break_even *= 2;
3592 #if QSORT_ORDER_GUESS == 3
3593 int prev_break = qsort_break_even;
3594 qsort_break_even *= qsort_break_even;
3595 if (qsort_break_even < prev_break) {
3596 qsort_break_even = (part_right - part_left) + 1;
3600 qsort_break_even = QSORT_BREAK_EVEN;
3604 if (part_left < pc_left) {
3605 /* There are elements on the left which need more processing.
3606 Check the right as well before deciding what to do.
3608 if (pc_right < part_right) {
3609 /* We have two partitions to be sorted. Stack the biggest one
3610 and process the smallest one on the next iteration. This
3611 minimizes the stack height by insuring that any additional
3612 stack entries must come from the smallest partition which
3613 (because it is smallest) will have the fewest
3614 opportunities to generate additional stack entries.
3616 if ((part_right - pc_right) > (pc_left - part_left)) {
3617 /* stack the right partition, process the left */
3618 partition_stack[next_stack_entry].left = pc_right + 1;
3619 partition_stack[next_stack_entry].right = part_right;
3620 #ifdef QSORT_ORDER_GUESS
3621 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3623 part_right = pc_left - 1;
3625 /* stack the left partition, process the right */
3626 partition_stack[next_stack_entry].left = part_left;
3627 partition_stack[next_stack_entry].right = pc_left - 1;
3628 #ifdef QSORT_ORDER_GUESS
3629 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3631 part_left = pc_right + 1;
3633 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3636 /* The elements on the left are the only remaining elements
3637 that need sorting, arrange for them to be processed as the
3640 part_right = pc_left - 1;
3642 } else if (pc_right < part_right) {
3643 /* There is only one chunk on the right to be sorted, make it
3644 the new partition and loop back around.
3646 part_left = pc_right + 1;
3648 /* This whole partition wound up in the pivot chunk, so
3649 we need to get a new partition off the stack.
3651 if (next_stack_entry == 0) {
3652 /* the stack is empty - we are done */
3656 part_left = partition_stack[next_stack_entry].left;
3657 part_right = partition_stack[next_stack_entry].right;
3658 #ifdef QSORT_ORDER_GUESS
3659 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3663 /* This partition is too small to fool with qsort complexity, just
3664 do an ordinary insertion sort to minimize overhead.
3667 /* Assume 1st element is in right place already, and start checking
3668 at 2nd element to see where it should be inserted.
3670 for (i = part_left + 1; i <= part_right; ++i) {
3672 /* Scan (backwards - just in case 'i' is already in right place)
3673 through the elements already sorted to see if the ith element
3674 belongs ahead of one of them.
3676 for (j = i - 1; j >= part_left; --j) {
3677 if (qsort_cmp(i, j) >= 0) {
3678 /* i belongs right after j
3685 /* Looks like we really need to move some things
3689 for (k = i - 1; k >= j; --k)
3690 array[k + 1] = array[k];
3695 /* That partition is now sorted, grab the next one, or get out
3696 of the loop if there aren't any more.
3699 if (next_stack_entry == 0) {
3700 /* the stack is empty - we are done */
3704 part_left = partition_stack[next_stack_entry].left;
3705 part_right = partition_stack[next_stack_entry].right;
3706 #ifdef QSORT_ORDER_GUESS
3707 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3712 /* Believe it or not, the array is sorted at this point! */