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->*PL_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 (PL_op->op_flags & OPf_SPECIAL)
112 PL_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 PL_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 && PL_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 = PL_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(PL_chopset, ' ') != Nullch);
291 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
292 SvREADONLY_off(tmpForm);
293 doparseform(tmpForm);
296 SvPV_force(PL_formtarget, len);
297 t = SvGROW(PL_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(PL_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(PL_formtarget, t - SvPVX(PL_formtarget));
475 sv_catpvn(PL_formtarget, item, itemsize);
476 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + SvCUR(tmpForm) + 1);
477 t = SvPVX(PL_formtarget) + SvCUR(PL_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(PL_formtarget, t - SvPVX(PL_formtarget));
516 lines += FmLINES(PL_formtarget);
519 if (strnEQ(linemark, linemark - arg, arg))
520 DIE("Runaway format");
522 FmLINES(PL_formtarget) = lines;
524 RETURNOP(cLISTOP->op_first);
535 arg = fieldsize - itemsize;
542 if (strnEQ(s," ",3)) {
543 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
554 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
555 FmLINES(PL_formtarget) += lines;
567 if (PL_stack_base + *PL_markstack_ptr == SP) {
569 if (GIMME_V == G_SCALAR)
571 RETURNOP(PL_op->op_next->op_next);
573 PL_stack_sp = PL_stack_base + *PL_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(PL_defgv));
584 #endif /* USE_THREADS */
585 ENTER; /* enter inner scope */
588 src = PL_stack_base[*PL_markstack_ptr];
593 if (PL_op->op_type == OP_MAPSTART)
594 pp_pushmark(ARGS); /* push top */
595 return ((LOGOP*)PL_op->op_next)->op_other;
600 DIE("panic: mapstart"); /* uses grepstart */
606 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
612 ++PL_markstack_ptr[-1];
614 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
615 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
616 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
621 PL_markstack_ptr[-1] += shift;
622 *PL_markstack_ptr += shift;
626 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
629 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
631 LEAVE; /* exit inner scope */
634 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
638 (void)POPMARK; /* pop top */
639 LEAVE; /* exit outer scope */
640 (void)POPMARK; /* pop src */
641 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
642 (void)POPMARK; /* pop dst */
643 SP = PL_stack_base + POPMARK; /* pop original mark */
644 if (gimme == G_SCALAR) {
648 else if (gimme == G_ARRAY)
655 ENTER; /* enter inner scope */
658 src = PL_stack_base[PL_markstack_ptr[-1]];
662 RETURNOP(cLOGOP->op_other);
668 djSP; dMARK; dORIGMARK;
670 SV **myorigmark = ORIGMARK;
676 OP* nextop = PL_op->op_next;
678 if (gimme != G_ARRAY) {
684 SAVEPPTR(PL_sortcop);
685 if (PL_op->op_flags & OPf_STACKED) {
686 if (PL_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 PL_sortcop = kid->op_next;
691 stash = PL_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 PL_sortcop = CvSTART(cv);
712 SAVESPTR(CvROOT(cv)->op_ppaddr);
713 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
716 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
721 stash = PL_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 (!PL_sortcop && !SvPOK(*up))
730 (void)sv_2pv(*up, &PL_na);
734 max = --up - myorigmark;
739 bool oldcatch = CATCH_GET;
745 PUSHSTACKi(PERLSI_SORT);
746 if (PL_sortstash != stash) {
747 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
748 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
749 PL_sortstash = stash;
752 SAVESPTR(GvSV(PL_firstgv));
753 SAVESPTR(GvSV(PL_secondgv));
755 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
756 if (!(PL_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 PL_sortcxix = cxstack_ix;
765 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
767 POPBLOCK(cx,PL_curpm);
774 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
775 qsortsv(ORIGMARK+1, max,
776 (PL_op->op_private & OPpLOCALE)
777 ? FUNC_NAME_TO_PTR(sv_cmp_locale)
778 : FUNC_NAME_TO_PTR(sv_cmp));
782 PL_stack_sp = ORIGMARK + max;
790 if (GIMME == G_ARRAY)
791 return cCONDOP->op_true;
792 return SvTRUEx(PAD_SV(PL_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(PL_op->op_targ);
806 if ((PL_op->op_private & OPpFLIP_LINENUM)
807 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
809 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
810 if (PL_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 SvPV_force(sv,PL_na);
860 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
862 if (strEQ(SvPVX(sv),tmps))
864 sv = sv_2mortal(newSVsv(sv));
871 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
873 if ((PL_op->op_private & OPpFLIP_LINENUM)
874 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
876 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
877 sv_catpv(targ, "E0");
888 dopoptolabel(char *label)
892 register PERL_CONTEXT *cx;
894 for (i = cxstack_ix; i >= 0; i--) {
896 switch (cx->cx_type) {
899 warn("Exiting substitution via %s", op_name[PL_op->op_type]);
903 warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
907 warn("Exiting eval via %s", op_name[PL_op->op_type]);
911 warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
914 if (!cx->blk_loop.label ||
915 strNE(label, cx->blk_loop.label) ) {
916 DEBUG_l(deb("(Skipping label #%ld %s)\n",
917 (long)i, cx->blk_loop.label));
920 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
930 I32 gimme = block_gimme();
931 return (gimme == G_VOID) ? G_SCALAR : gimme;
940 cxix = dopoptosub(cxstack_ix);
944 switch (cxstack[cxix].blk_gimme) {
952 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
959 dopoptosub(I32 startingblock)
962 return dopoptosub_at(cxstack, startingblock);
966 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
970 register PERL_CONTEXT *cx;
971 for (i = startingblock; i >= 0; i--) {
973 switch (cx->cx_type) {
978 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
986 dopoptoeval(I32 startingblock)
990 register PERL_CONTEXT *cx;
991 for (i = startingblock; i >= 0; i--) {
993 switch (cx->cx_type) {
997 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1005 dopoptoloop(I32 startingblock)
1009 register PERL_CONTEXT *cx;
1010 for (i = startingblock; i >= 0; i--) {
1012 switch (cx->cx_type) {
1015 warn("Exiting substitution via %s", op_name[PL_op->op_type]);
1019 warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
1023 warn("Exiting eval via %s", op_name[PL_op->op_type]);
1027 warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
1030 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1041 register PERL_CONTEXT *cx;
1045 while (cxstack_ix > cxix) {
1046 cx = &cxstack[cxstack_ix];
1047 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1048 (long) cxstack_ix, block_type[cx->cx_type]));
1049 /* Note: we don't need to restore the base context info till the end. */
1050 switch (cx->cx_type) {
1053 continue; /* not break */
1071 die_where(char *message)
1076 register PERL_CONTEXT *cx;
1081 if (PL_in_eval & 4) {
1083 STRLEN klen = strlen(message);
1085 svp = hv_fetch(ERRHV, message, klen, TRUE);
1088 static char prefix[] = "\t(in cleanup) ";
1090 sv_upgrade(*svp, SVt_IV);
1091 (void)SvIOK_only(*svp);
1094 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1095 sv_catpvn(err, prefix, sizeof(prefix)-1);
1096 sv_catpvn(err, message, klen);
1102 sv_setpv(ERRSV, message);
1105 message = SvPVx(ERRSV, PL_na);
1107 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1115 if (cxix < cxstack_ix)
1118 POPBLOCK(cx,PL_curpm);
1119 if (cx->cx_type != CXt_EVAL) {
1120 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1125 if (gimme == G_SCALAR)
1126 *++newsp = &PL_sv_undef;
1127 PL_stack_sp = newsp;
1131 if (optype == OP_REQUIRE) {
1132 char* msg = SvPVx(ERRSV, PL_na);
1133 DIE("%s", *msg ? msg : "Compilation failed in require");
1135 return pop_return();
1138 PerlIO_printf(PerlIO_stderr(), "%s",message);
1139 PerlIO_flush(PerlIO_stderr());
1148 if (SvTRUE(left) != SvTRUE(right))
1160 RETURNOP(cLOGOP->op_other);
1169 RETURNOP(cLOGOP->op_other);
1175 register I32 cxix = dopoptosub(cxstack_ix);
1176 register PERL_CONTEXT *cx;
1177 register PERL_CONTEXT *ccstack = cxstack;
1178 PERL_SI *top_si = PL_curstackinfo;
1189 /* we may be in a higher stacklevel, so dig down deeper */
1190 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1191 top_si = top_si->si_prev;
1192 ccstack = top_si->si_cxstack;
1193 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1196 if (GIMME != G_ARRAY)
1200 if (PL_DBsub && cxix >= 0 &&
1201 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1205 cxix = dopoptosub_at(ccstack, cxix - 1);
1208 cx = &ccstack[cxix];
1209 if (ccstack[cxix].cx_type == CXt_SUB) {
1210 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1211 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1212 field below is defined for any cx. */
1213 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1214 cx = &ccstack[dbcxix];
1217 if (GIMME != G_ARRAY) {
1218 hv = cx->blk_oldcop->cop_stash;
1220 PUSHs(&PL_sv_undef);
1223 sv_setpv(TARG, HvNAME(hv));
1229 hv = cx->blk_oldcop->cop_stash;
1231 PUSHs(&PL_sv_undef);
1233 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1234 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1235 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1238 if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
1240 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1241 PUSHs(sv_2mortal(sv));
1242 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1245 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1246 PUSHs(sv_2mortal(newSViv(0)));
1248 gimme = (I32)cx->blk_gimme;
1249 if (gimme == G_VOID)
1250 PUSHs(&PL_sv_undef);
1252 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1253 if (cx->cx_type == CXt_EVAL) {
1254 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1255 PUSHs(cx->blk_eval.cur_text);
1258 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1259 /* Require, put the name. */
1260 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1264 else if (cx->cx_type == CXt_SUB &&
1265 cx->blk_sub.hasargs &&
1266 PL_curcop->cop_stash == PL_debstash)
1268 AV *ary = cx->blk_sub.argarray;
1269 int off = AvARRAY(ary) - AvALLOC(ary);
1273 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1276 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1279 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1280 av_extend(PL_dbargs, AvFILLp(ary) + off);
1281 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1282 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1288 sortcv(SV *a, SV *b)
1291 I32 oldsaveix = PL_savestack_ix;
1292 I32 oldscopeix = PL_scopestack_ix;
1294 GvSV(PL_firstgv) = a;
1295 GvSV(PL_secondgv) = b;
1296 PL_stack_sp = PL_stack_base;
1299 if (PL_stack_sp != PL_stack_base + 1)
1300 croak("Sort subroutine didn't return single value");
1301 if (!SvNIOKp(*PL_stack_sp))
1302 croak("Sort subroutine didn't return a numeric value");
1303 result = SvIV(*PL_stack_sp);
1304 while (PL_scopestack_ix > oldscopeix) {
1307 leave_scope(oldsaveix);
1320 sv_reset(tmps, PL_curcop->cop_stash);
1332 PL_curcop = (COP*)PL_op;
1333 TAINT_NOT; /* Each statement is presumed innocent */
1334 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1337 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1341 register PERL_CONTEXT *cx;
1342 I32 gimme = G_ARRAY;
1349 DIE("No DB::DB routine defined");
1351 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1363 push_return(PL_op->op_next);
1364 PUSHBLOCK(cx, CXt_SUB, SP);
1367 (void)SvREFCNT_inc(cv);
1368 SAVESPTR(PL_curpad);
1369 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1370 RETURNOP(CvSTART(cv));
1384 register PERL_CONTEXT *cx;
1385 I32 gimme = GIMME_V;
1392 if (PL_op->op_flags & OPf_SPECIAL)
1393 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1395 #endif /* USE_THREADS */
1396 if (PL_op->op_targ) {
1397 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1402 (void)save_scalar(gv);
1403 svp = &GvSV(gv); /* symbol table variable */
1408 PUSHBLOCK(cx, CXt_LOOP, SP);
1409 PUSHLOOP(cx, svp, MARK);
1410 if (PL_op->op_flags & OPf_STACKED) {
1411 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1412 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1414 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1415 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1416 if (SvNV(sv) < IV_MIN ||
1417 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1418 croak("Range iterator outside integer range");
1419 cx->blk_loop.iterix = SvIV(sv);
1420 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1423 cx->blk_loop.iterlval = newSVsv(sv);
1427 cx->blk_loop.iterary = PL_curstack;
1428 AvFILLp(PL_curstack) = SP - PL_stack_base;
1429 cx->blk_loop.iterix = MARK - PL_stack_base;
1438 register PERL_CONTEXT *cx;
1439 I32 gimme = GIMME_V;
1445 PUSHBLOCK(cx, CXt_LOOP, SP);
1446 PUSHLOOP(cx, 0, SP);
1454 register PERL_CONTEXT *cx;
1455 struct block_loop cxloop;
1463 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1466 if (gimme == G_VOID)
1468 else if (gimme == G_SCALAR) {
1470 *++newsp = sv_mortalcopy(*SP);
1472 *++newsp = &PL_sv_undef;
1476 *++newsp = sv_mortalcopy(*++mark);
1477 TAINT_NOT; /* Each item is independent */
1483 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1484 PL_curpm = newpm; /* ... and pop $1 et al */
1496 register PERL_CONTEXT *cx;
1497 struct block_sub cxsub;
1498 bool popsub2 = FALSE;
1504 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1505 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1506 if (cxstack_ix > PL_sortcxix)
1507 dounwind(PL_sortcxix);
1508 AvARRAY(PL_curstack)[1] = *SP;
1509 PL_stack_sp = PL_stack_base + 1;
1514 cxix = dopoptosub(cxstack_ix);
1516 DIE("Can't return outside a subroutine");
1517 if (cxix < cxstack_ix)
1521 switch (cx->cx_type) {
1523 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1528 if (optype == OP_REQUIRE &&
1529 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1531 /* Unassume the success we assumed earlier. */
1532 char *name = cx->blk_eval.old_name;
1533 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1534 DIE("%s did not return a true value", name);
1538 DIE("panic: return");
1542 if (gimme == G_SCALAR) {
1545 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1547 *++newsp = SvREFCNT_inc(*SP);
1552 *++newsp = sv_mortalcopy(*SP);
1555 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1557 *++newsp = sv_mortalcopy(*SP);
1559 *++newsp = &PL_sv_undef;
1561 else if (gimme == G_ARRAY) {
1562 while (++MARK <= SP) {
1563 *++newsp = (popsub2 && SvTEMP(*MARK))
1564 ? *MARK : sv_mortalcopy(*MARK);
1565 TAINT_NOT; /* Each item is independent */
1568 PL_stack_sp = newsp;
1570 /* Stack values are safe: */
1572 POPSUB2(); /* release CV and @_ ... */
1574 PL_curpm = newpm; /* ... and pop $1 et al */
1577 return pop_return();
1584 register PERL_CONTEXT *cx;
1585 struct block_loop cxloop;
1586 struct block_sub cxsub;
1593 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1595 if (PL_op->op_flags & OPf_SPECIAL) {
1596 cxix = dopoptoloop(cxstack_ix);
1598 DIE("Can't \"last\" outside a block");
1601 cxix = dopoptolabel(cPVOP->op_pv);
1603 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1605 if (cxix < cxstack_ix)
1609 switch (cx->cx_type) {
1611 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1613 nextop = cxloop.last_op->op_next;
1616 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1618 nextop = pop_return();
1622 nextop = pop_return();
1629 if (gimme == G_SCALAR) {
1631 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1632 ? *SP : sv_mortalcopy(*SP);
1634 *++newsp = &PL_sv_undef;
1636 else if (gimme == G_ARRAY) {
1637 while (++MARK <= SP) {
1638 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1639 ? *MARK : sv_mortalcopy(*MARK);
1640 TAINT_NOT; /* Each item is independent */
1646 /* Stack values are safe: */
1649 POPLOOP2(); /* release loop vars ... */
1653 POPSUB2(); /* release CV and @_ ... */
1656 PL_curpm = newpm; /* ... and pop $1 et al */
1665 register PERL_CONTEXT *cx;
1668 if (PL_op->op_flags & OPf_SPECIAL) {
1669 cxix = dopoptoloop(cxstack_ix);
1671 DIE("Can't \"next\" outside a block");
1674 cxix = dopoptolabel(cPVOP->op_pv);
1676 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1678 if (cxix < cxstack_ix)
1682 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1683 LEAVE_SCOPE(oldsave);
1684 return cx->blk_loop.next_op;
1690 register PERL_CONTEXT *cx;
1693 if (PL_op->op_flags & OPf_SPECIAL) {
1694 cxix = dopoptoloop(cxstack_ix);
1696 DIE("Can't \"redo\" outside a block");
1699 cxix = dopoptolabel(cPVOP->op_pv);
1701 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1703 if (cxix < cxstack_ix)
1707 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1708 LEAVE_SCOPE(oldsave);
1709 return cx->blk_loop.redo_op;
1713 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1717 static char too_deep[] = "Target of goto is too deeply nested";
1721 if (o->op_type == OP_LEAVE ||
1722 o->op_type == OP_SCOPE ||
1723 o->op_type == OP_LEAVELOOP ||
1724 o->op_type == OP_LEAVETRY)
1726 *ops++ = cUNOPo->op_first;
1731 if (o->op_flags & OPf_KIDS) {
1733 /* First try all the kids at this level, since that's likeliest. */
1734 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1735 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1736 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1739 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1740 if (kid == PL_lastgotoprobe)
1742 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1744 (ops[-1]->op_type != OP_NEXTSTATE &&
1745 ops[-1]->op_type != OP_DBSTATE)))
1747 if (o = dofindlabel(kid, label, ops, oplimit))
1757 return pp_goto(ARGS);
1766 register PERL_CONTEXT *cx;
1767 #define GOTO_DEPTH 64
1768 OP *enterops[GOTO_DEPTH];
1770 int do_dump = (PL_op->op_type == OP_DUMP);
1773 if (PL_op->op_flags & OPf_STACKED) {
1776 /* This egregious kludge implements goto &subroutine */
1777 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1779 register PERL_CONTEXT *cx;
1780 CV* cv = (CV*)SvRV(sv);
1785 if (!CvROOT(cv) && !CvXSUB(cv)) {
1787 SV *tmpstr = sv_newmortal();
1788 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1789 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1791 DIE("Goto undefined subroutine");
1794 /* First do some returnish stuff. */
1795 cxix = dopoptosub(cxstack_ix);
1797 DIE("Can't goto subroutine outside a subroutine");
1798 if (cxix < cxstack_ix)
1801 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1802 DIE("Can't goto subroutine from an eval-string");
1804 if (cx->cx_type == CXt_SUB &&
1805 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1806 AV* av = cx->blk_sub.argarray;
1808 items = AvFILLp(av) + 1;
1810 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1811 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1812 PL_stack_sp += items;
1814 SvREFCNT_dec(GvAV(PL_defgv));
1815 GvAV(PL_defgv) = cx->blk_sub.savearray;
1816 #endif /* USE_THREADS */
1820 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1824 av = (AV*)PL_curpad[0];
1826 av = GvAV(PL_defgv);
1828 items = AvFILLp(av) + 1;
1830 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1831 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1832 PL_stack_sp += items;
1834 if (cx->cx_type == CXt_SUB &&
1835 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1836 SvREFCNT_dec(cx->blk_sub.cv);
1837 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1838 LEAVE_SCOPE(oldsave);
1840 /* Now do some callish stuff. */
1843 if (CvOLDSTYLE(cv)) {
1844 I32 (*fp3)_((int,int,int));
1849 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1850 items = (*fp3)(CvXSUBANY(cv).any_i32,
1851 mark - PL_stack_base + 1,
1853 SP = PL_stack_base + items;
1859 PL_stack_sp--; /* There is no cv arg. */
1860 /* Push a mark for the start of arglist */
1862 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1863 /* Pop the current context like a decent sub should */
1864 POPBLOCK(cx, PL_curpm);
1865 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1868 return pop_return();
1871 AV* padlist = CvPADLIST(cv);
1872 SV** svp = AvARRAY(padlist);
1873 if (cx->cx_type == CXt_EVAL) {
1874 PL_in_eval = cx->blk_eval.old_in_eval;
1875 PL_eval_root = cx->blk_eval.old_eval_root;
1876 cx->cx_type = CXt_SUB;
1877 cx->blk_sub.hasargs = 0;
1879 cx->blk_sub.cv = cv;
1880 cx->blk_sub.olddepth = CvDEPTH(cv);
1882 if (CvDEPTH(cv) < 2)
1883 (void)SvREFCNT_inc(cv);
1884 else { /* save temporaries on recursion? */
1885 if (CvDEPTH(cv) == 100 && PL_dowarn)
1886 sub_crush_depth(cv);
1887 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1888 AV *newpad = newAV();
1889 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1890 I32 ix = AvFILLp((AV*)svp[1]);
1891 svp = AvARRAY(svp[0]);
1892 for ( ;ix > 0; ix--) {
1893 if (svp[ix] != &PL_sv_undef) {
1894 char *name = SvPVX(svp[ix]);
1895 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1898 /* outer lexical or anon code */
1899 av_store(newpad, ix,
1900 SvREFCNT_inc(oldpad[ix]) );
1902 else { /* our own lexical */
1904 av_store(newpad, ix, sv = (SV*)newAV());
1905 else if (*name == '%')
1906 av_store(newpad, ix, sv = (SV*)newHV());
1908 av_store(newpad, ix, sv = NEWSV(0,0));
1913 av_store(newpad, ix, sv = NEWSV(0,0));
1917 if (cx->blk_sub.hasargs) {
1920 av_store(newpad, 0, (SV*)av);
1921 AvFLAGS(av) = AVf_REIFY;
1923 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1924 AvFILLp(padlist) = CvDEPTH(cv);
1925 svp = AvARRAY(padlist);
1929 if (!cx->blk_sub.hasargs) {
1930 AV* av = (AV*)PL_curpad[0];
1932 items = AvFILLp(av) + 1;
1934 /* Mark is at the end of the stack. */
1936 Copy(AvARRAY(av), SP + 1, items, SV*);
1941 #endif /* USE_THREADS */
1942 SAVESPTR(PL_curpad);
1943 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1945 if (cx->blk_sub.hasargs)
1946 #endif /* USE_THREADS */
1948 AV* av = (AV*)PL_curpad[0];
1952 cx->blk_sub.savearray = GvAV(PL_defgv);
1953 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1954 #endif /* USE_THREADS */
1955 cx->blk_sub.argarray = av;
1958 if (items >= AvMAX(av) + 1) {
1960 if (AvARRAY(av) != ary) {
1961 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1962 SvPVX(av) = (char*)ary;
1964 if (items >= AvMAX(av) + 1) {
1965 AvMAX(av) = items - 1;
1966 Renew(ary,items+1,SV*);
1968 SvPVX(av) = (char*)ary;
1971 Copy(mark,AvARRAY(av),items,SV*);
1972 AvFILLp(av) = items - 1;
1980 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1982 * We do not care about using sv to call CV;
1983 * it's for informational purposes only.
1985 SV *sv = GvSV(PL_DBsub);
1988 if (PERLDB_SUB_NN) {
1989 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1992 gv_efullname3(sv, CvGV(cv), Nullch);
1995 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1996 PUSHMARK( PL_stack_sp );
1997 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2001 RETURNOP(CvSTART(cv));
2005 label = SvPV(sv,PL_na);
2007 else if (PL_op->op_flags & OPf_SPECIAL) {
2009 DIE("goto must have label");
2012 label = cPVOP->op_pv;
2014 if (label && *label) {
2019 PL_lastgotoprobe = 0;
2021 for (ix = cxstack_ix; ix >= 0; ix--) {
2023 switch (cx->cx_type) {
2025 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2028 gotoprobe = cx->blk_oldcop->op_sibling;
2034 gotoprobe = cx->blk_oldcop->op_sibling;
2036 gotoprobe = PL_main_root;
2039 if (CvDEPTH(cx->blk_sub.cv)) {
2040 gotoprobe = CvROOT(cx->blk_sub.cv);
2045 DIE("Can't \"goto\" outside a block");
2049 gotoprobe = PL_main_root;
2052 retop = dofindlabel(gotoprobe, label,
2053 enterops, enterops + GOTO_DEPTH);
2056 PL_lastgotoprobe = gotoprobe;
2059 DIE("Can't find label %s", label);
2061 /* pop unwanted frames */
2063 if (ix < cxstack_ix) {
2070 oldsave = PL_scopestack[PL_scopestack_ix];
2071 LEAVE_SCOPE(oldsave);
2074 /* push wanted frames */
2076 if (*enterops && enterops[1]) {
2078 for (ix = 1; enterops[ix]; ix++) {
2079 PL_op = enterops[ix];
2080 /* Eventually we may want to stack the needed arguments
2081 * for each op. For now, we punt on the hard ones. */
2082 if (PL_op->op_type == OP_ENTERITER)
2083 DIE("Can't \"goto\" into the middle of a foreach loop",
2085 (CALLOP->op_ppaddr)(ARGS);
2093 if (!retop) retop = PL_main_start;
2095 PL_restartop = retop;
2096 PL_do_undump = TRUE;
2100 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2101 PL_do_undump = FALSE;
2104 if (PL_top_env->je_prev) {
2105 PL_restartop = retop;
2122 if (anum == 1 && VMSISH_EXIT)
2127 PUSHs(&PL_sv_undef);
2135 double value = SvNVx(GvSV(cCOP->cop_gv));
2136 register I32 match = I_32(value);
2139 if (((double)match) > value)
2140 --match; /* was fractional--truncate other way */
2142 match -= cCOP->uop.scop.scop_offset;
2145 else if (match > cCOP->uop.scop.scop_max)
2146 match = cCOP->uop.scop.scop_max;
2147 PL_op = cCOP->uop.scop.scop_next[match];
2157 PL_op = PL_op->op_next; /* can't assume anything */
2159 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2160 match -= cCOP->uop.scop.scop_offset;
2163 else if (match > cCOP->uop.scop.scop_max)
2164 match = cCOP->uop.scop.scop_max;
2165 PL_op = cCOP->uop.scop.scop_next[match];
2174 save_lines(AV *array, SV *sv)
2176 register char *s = SvPVX(sv);
2177 register char *send = SvPVX(sv) + SvCUR(sv);
2179 register I32 line = 1;
2181 while (s && s < send) {
2182 SV *tmpstr = NEWSV(85,0);
2184 sv_upgrade(tmpstr, SVt_PVMG);
2185 t = strchr(s, '\n');
2191 sv_setpvn(tmpstr, s, t - s);
2192 av_store(array, line++, tmpstr);
2207 assert(CATCH_GET == TRUE);
2208 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2212 default: /* topmost level handles it */
2218 if (!PL_restartop) {
2219 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2222 PL_op = PL_restartop;
2235 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2236 /* sv Text to convert to OP tree. */
2237 /* startop op_free() this to undo. */
2238 /* code Short string id of the caller. */
2240 dSP; /* Make POPBLOCK work. */
2243 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2246 OP *oop = PL_op, *rop;
2247 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2253 /* switch to eval mode */
2255 if (PL_curcop == &PL_compiling) {
2256 SAVESPTR(PL_compiling.cop_stash);
2257 PL_compiling.cop_stash = PL_curstash;
2259 SAVESPTR(PL_compiling.cop_filegv);
2260 SAVEI16(PL_compiling.cop_line);
2261 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2262 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2263 PL_compiling.cop_line = 1;
2264 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2265 deleting the eval's FILEGV from the stash before gv_check() runs
2266 (i.e. before run-time proper). To work around the coredump that
2267 ensues, we always turn GvMULTI_on for any globals that were
2268 introduced within evals. See force_ident(). GSAR 96-10-12 */
2269 safestr = savepv(tmpbuf);
2270 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2272 #ifdef OP_IN_REGISTER
2280 PL_op->op_type = 0; /* Avoid uninit warning. */
2281 PL_op->op_flags = 0; /* Avoid uninit warning. */
2282 PUSHBLOCK(cx, CXt_EVAL, SP);
2283 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2284 rop = doeval(G_SCALAR, startop);
2285 POPBLOCK(cx,PL_curpm);
2288 (*startop)->op_type = OP_NULL;
2289 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2291 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2293 #ifdef OP_IN_REGISTER
2299 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2301 doeval(int gimme, OP** startop)
2314 /* set up a scratch pad */
2317 SAVESPTR(PL_curpad);
2318 SAVESPTR(PL_comppad);
2319 SAVESPTR(PL_comppad_name);
2320 SAVEI32(PL_comppad_name_fill);
2321 SAVEI32(PL_min_intro_pending);
2322 SAVEI32(PL_max_intro_pending);
2325 for (i = cxstack_ix; i >= 0; i--) {
2326 PERL_CONTEXT *cx = &cxstack[i];
2327 if (cx->cx_type == CXt_EVAL)
2329 else if (cx->cx_type == CXt_SUB) {
2330 caller = cx->blk_sub.cv;
2335 SAVESPTR(PL_compcv);
2336 PL_compcv = (CV*)NEWSV(1104,0);
2337 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2338 CvUNIQUE_on(PL_compcv);
2340 CvOWNER(PL_compcv) = 0;
2341 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2342 MUTEX_INIT(CvMUTEXP(PL_compcv));
2343 #endif /* USE_THREADS */
2345 PL_comppad = newAV();
2346 av_push(PL_comppad, Nullsv);
2347 PL_curpad = AvARRAY(PL_comppad);
2348 PL_comppad_name = newAV();
2349 PL_comppad_name_fill = 0;
2350 PL_min_intro_pending = 0;
2353 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2354 PL_curpad[0] = (SV*)newAV();
2355 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2356 #endif /* USE_THREADS */
2358 comppadlist = newAV();
2359 AvREAL_off(comppadlist);
2360 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2361 av_store(comppadlist, 1, (SV*)PL_comppad);
2362 CvPADLIST(PL_compcv) = comppadlist;
2364 if (!saveop || saveop->op_type != OP_REQUIRE)
2365 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2367 SAVEFREESV(PL_compcv);
2369 /* make sure we compile in the right package */
2371 newstash = PL_curcop->cop_stash;
2372 if (PL_curstash != newstash) {
2373 SAVESPTR(PL_curstash);
2374 PL_curstash = newstash;
2376 SAVESPTR(PL_beginav);
2377 PL_beginav = newAV();
2378 SAVEFREESV(PL_beginav);
2380 /* try to compile it */
2382 PL_eval_root = Nullop;
2384 PL_curcop = &PL_compiling;
2385 PL_curcop->cop_arybase = 0;
2386 SvREFCNT_dec(PL_rs);
2387 PL_rs = newSVpv("\n", 1);
2388 if (saveop && saveop->op_flags & OPf_SPECIAL)
2392 if (yyparse() || PL_error_count || !PL_eval_root) {
2396 I32 optype = 0; /* Might be reset by POPEVAL. */
2400 op_free(PL_eval_root);
2401 PL_eval_root = Nullop;
2403 SP = PL_stack_base + POPMARK; /* pop original mark */
2405 POPBLOCK(cx,PL_curpm);
2411 if (optype == OP_REQUIRE) {
2412 char* msg = SvPVx(ERRSV, PL_na);
2413 DIE("%s", *msg ? msg : "Compilation failed in require");
2414 } else if (startop) {
2415 char* msg = SvPVx(ERRSV, PL_na);
2417 POPBLOCK(cx,PL_curpm);
2419 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2421 SvREFCNT_dec(PL_rs);
2422 PL_rs = SvREFCNT_inc(PL_nrs);
2424 MUTEX_LOCK(&PL_eval_mutex);
2426 COND_SIGNAL(&PL_eval_cond);
2427 MUTEX_UNLOCK(&PL_eval_mutex);
2428 #endif /* USE_THREADS */
2431 SvREFCNT_dec(PL_rs);
2432 PL_rs = SvREFCNT_inc(PL_nrs);
2433 PL_compiling.cop_line = 0;
2435 *startop = PL_eval_root;
2436 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2437 CvOUTSIDE(PL_compcv) = Nullcv;
2439 SAVEFREEOP(PL_eval_root);
2441 scalarvoid(PL_eval_root);
2442 else if (gimme & G_ARRAY)
2445 scalar(PL_eval_root);
2447 DEBUG_x(dump_eval());
2449 /* Register with debugger: */
2450 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2451 CV *cv = perl_get_cv("DB::postponed", FALSE);
2455 XPUSHs((SV*)PL_compiling.cop_filegv);
2457 perl_call_sv((SV*)cv, G_DISCARD);
2461 /* compiled okay, so do it */
2463 CvDEPTH(PL_compcv) = 1;
2464 SP = PL_stack_base + POPMARK; /* pop original mark */
2465 PL_op = saveop; /* The caller may need it. */
2467 MUTEX_LOCK(&PL_eval_mutex);
2469 COND_SIGNAL(&PL_eval_cond);
2470 MUTEX_UNLOCK(&PL_eval_mutex);
2471 #endif /* USE_THREADS */
2473 RETURNOP(PL_eval_start);
2479 register PERL_CONTEXT *cx;
2484 SV *namesv = Nullsv;
2486 I32 gimme = G_SCALAR;
2487 PerlIO *tryrsfp = 0;
2490 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2491 SET_NUMERIC_STANDARD();
2492 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2493 DIE("Perl %s required--this is only version %s, stopped",
2494 SvPV(sv,PL_na),PL_patchlevel);
2497 name = SvPV(sv, len);
2498 if (!(name && len > 0 && *name))
2499 DIE("Null filename used");
2500 TAINT_PROPER("require");
2501 if (PL_op->op_type == OP_REQUIRE &&
2502 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2503 *svp != &PL_sv_undef)
2506 /* prepare to compile file */
2511 (name[1] == '.' && name[2] == '/')))
2513 || (name[0] && name[1] == ':')
2516 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2519 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2520 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2525 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2528 AV *ar = GvAVn(PL_incgv);
2532 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2535 namesv = NEWSV(806, 0);
2536 for (i = 0; i <= AvFILL(ar); i++) {
2537 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2540 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2542 sv_setpv(namesv, unixdir);
2543 sv_catpv(namesv, unixname);
2545 sv_setpvf(namesv, "%s/%s", dir, name);
2547 tryname = SvPVX(namesv);
2548 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2550 if (tryname[0] == '.' && tryname[1] == '/')
2557 SAVESPTR(PL_compiling.cop_filegv);
2558 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2559 SvREFCNT_dec(namesv);
2561 if (PL_op->op_type == OP_REQUIRE) {
2562 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2563 SV *dirmsgsv = NEWSV(0, 0);
2564 AV *ar = GvAVn(PL_incgv);
2566 if (instr(SvPVX(msg), ".h "))
2567 sv_catpv(msg, " (change .h to .ph maybe?)");
2568 if (instr(SvPVX(msg), ".ph "))
2569 sv_catpv(msg, " (did you run h2ph?)");
2570 sv_catpv(msg, " (@INC contains:");
2571 for (i = 0; i <= AvFILL(ar); i++) {
2572 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2573 sv_setpvf(dirmsgsv, " %s", dir);
2574 sv_catsv(msg, dirmsgsv);
2576 sv_catpvn(msg, ")", 1);
2577 SvREFCNT_dec(dirmsgsv);
2584 /* Assume success here to prevent recursive requirement. */
2585 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2586 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2590 lex_start(sv_2mortal(newSVpv("",0)));
2591 if (PL_rsfp_filters){
2592 save_aptr(&PL_rsfp_filters);
2593 PL_rsfp_filters = NULL;
2597 name = savepv(name);
2602 /* switch to eval mode */
2604 push_return(PL_op->op_next);
2605 PUSHBLOCK(cx, CXt_EVAL, SP);
2606 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2608 PL_compiling.cop_line = 0;
2612 MUTEX_LOCK(&PL_eval_mutex);
2613 if (PL_eval_owner && PL_eval_owner != thr)
2614 while (PL_eval_owner)
2615 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2616 PL_eval_owner = thr;
2617 MUTEX_UNLOCK(&PL_eval_mutex);
2618 #endif /* USE_THREADS */
2619 return DOCATCH(doeval(G_SCALAR, NULL));
2624 return pp_require(ARGS);
2630 register PERL_CONTEXT *cx;
2632 I32 gimme = GIMME_V, was = PL_sub_generation;
2633 char tmpbuf[TYPE_DIGITS(long) + 12];
2638 if (!SvPV(sv,len) || !len)
2640 TAINT_PROPER("eval");
2646 /* switch to eval mode */
2648 SAVESPTR(PL_compiling.cop_filegv);
2649 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2650 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2651 PL_compiling.cop_line = 1;
2652 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2653 deleting the eval's FILEGV from the stash before gv_check() runs
2654 (i.e. before run-time proper). To work around the coredump that
2655 ensues, we always turn GvMULTI_on for any globals that were
2656 introduced within evals. See force_ident(). GSAR 96-10-12 */
2657 safestr = savepv(tmpbuf);
2658 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2660 PL_hints = PL_op->op_targ;
2662 push_return(PL_op->op_next);
2663 PUSHBLOCK(cx, CXt_EVAL, SP);
2664 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2666 /* prepare to compile string */
2668 if (PERLDB_LINE && PL_curstash != PL_debstash)
2669 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2672 MUTEX_LOCK(&PL_eval_mutex);
2673 if (PL_eval_owner && PL_eval_owner != thr)
2674 while (PL_eval_owner)
2675 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2676 PL_eval_owner = thr;
2677 MUTEX_UNLOCK(&PL_eval_mutex);
2678 #endif /* USE_THREADS */
2679 ret = doeval(gimme, NULL);
2680 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2681 && ret != PL_op->op_next) { /* Successive compilation. */
2682 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2684 return DOCATCH(ret);
2694 register PERL_CONTEXT *cx;
2696 U8 save_flags = PL_op -> op_flags;
2701 retop = pop_return();
2704 if (gimme == G_VOID)
2706 else if (gimme == G_SCALAR) {
2709 if (SvFLAGS(TOPs) & SVs_TEMP)
2712 *MARK = sv_mortalcopy(TOPs);
2716 *MARK = &PL_sv_undef;
2720 /* in case LEAVE wipes old return values */
2721 for (mark = newsp + 1; mark <= SP; mark++) {
2722 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2723 *mark = sv_mortalcopy(*mark);
2724 TAINT_NOT; /* Each item is independent */
2728 PL_curpm = newpm; /* Don't pop $1 et al till now */
2731 * Closures mentioned at top level of eval cannot be referenced
2732 * again, and their presence indirectly causes a memory leak.
2733 * (Note that the fact that compcv and friends are still set here
2734 * is, AFAIK, an accident.) --Chip
2736 if (AvFILLp(PL_comppad_name) >= 0) {
2737 SV **svp = AvARRAY(PL_comppad_name);
2739 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2741 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2743 svp[ix] = &PL_sv_undef;
2747 SvREFCNT_dec(CvOUTSIDE(sv));
2748 CvOUTSIDE(sv) = Nullcv;
2761 assert(CvDEPTH(PL_compcv) == 1);
2763 CvDEPTH(PL_compcv) = 0;
2766 if (optype == OP_REQUIRE &&
2767 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2769 /* Unassume the success we assumed earlier. */
2770 char *name = cx->blk_eval.old_name;
2771 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2772 retop = die("%s did not return a true value", name);
2773 /* die_where() did LEAVE, or we won't be here */
2777 if (!(save_flags & OPf_SPECIAL))
2787 register PERL_CONTEXT *cx;
2788 I32 gimme = GIMME_V;
2793 push_return(cLOGOP->op_other->op_next);
2794 PUSHBLOCK(cx, CXt_EVAL, SP);
2796 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2801 return DOCATCH(PL_op->op_next);
2811 register PERL_CONTEXT *cx;
2819 if (gimme == G_VOID)
2821 else if (gimme == G_SCALAR) {
2824 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2827 *MARK = sv_mortalcopy(TOPs);
2831 *MARK = &PL_sv_undef;
2836 /* in case LEAVE wipes old return values */
2837 for (mark = newsp + 1; mark <= SP; mark++) {
2838 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2839 *mark = sv_mortalcopy(*mark);
2840 TAINT_NOT; /* Each item is independent */
2844 PL_curpm = newpm; /* Don't pop $1 et al till now */
2855 register char *s = SvPV_force(sv, len);
2856 register char *send = s + len;
2857 register char *base;
2858 register I32 skipspaces = 0;
2861 bool postspace = FALSE;
2869 croak("Null picture in formline");
2871 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2876 *fpc++ = FF_LINEMARK;
2877 noblank = repeat = FALSE;
2895 case ' ': case '\t':
2906 *fpc++ = FF_LITERAL;
2914 *fpc++ = skipspaces;
2918 *fpc++ = FF_NEWLINE;
2922 arg = fpc - linepc + 1;
2929 *fpc++ = FF_LINEMARK;
2930 noblank = repeat = FALSE;
2939 ischop = s[-1] == '^';
2945 arg = (s - base) - 1;
2947 *fpc++ = FF_LITERAL;
2956 *fpc++ = FF_LINEGLOB;
2958 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2959 arg = ischop ? 512 : 0;
2969 arg |= 256 + (s - f);
2971 *fpc++ = s - base; /* fieldsize for FETCH */
2972 *fpc++ = FF_DECIMAL;
2977 bool ismore = FALSE;
2980 while (*++s == '>') ;
2981 prespace = FF_SPACE;
2983 else if (*s == '|') {
2984 while (*++s == '|') ;
2985 prespace = FF_HALFSPACE;
2990 while (*++s == '<') ;
2993 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2997 *fpc++ = s - base; /* fieldsize for FETCH */
2999 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3017 { /* need to jump to the next word */
3019 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3020 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3021 s = SvPVX(sv) + SvCUR(sv) + z;
3023 Copy(fops, s, arg, U16);
3025 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3030 * The rest of this file was derived from source code contributed
3033 * NOTE: this code was derived from Tom Horsley's qsort replacement
3034 * and should not be confused with the original code.
3037 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3039 Permission granted to distribute under the same terms as perl which are
3042 This program is free software; you can redistribute it and/or modify
3043 it under the terms of either:
3045 a) the GNU General Public License as published by the Free
3046 Software Foundation; either version 1, or (at your option) any
3049 b) the "Artistic License" which comes with this Kit.
3051 Details on the perl license can be found in the perl source code which
3052 may be located via the www.perl.com web page.
3054 This is the most wonderfulest possible qsort I can come up with (and
3055 still be mostly portable) My (limited) tests indicate it consistently
3056 does about 20% fewer calls to compare than does the qsort in the Visual
3057 C++ library, other vendors may vary.
3059 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3060 others I invented myself (or more likely re-invented since they seemed
3061 pretty obvious once I watched the algorithm operate for a while).
3063 Most of this code was written while watching the Marlins sweep the Giants
3064 in the 1997 National League Playoffs - no Braves fans allowed to use this
3065 code (just kidding :-).
3067 I realize that if I wanted to be true to the perl tradition, the only
3068 comment in this file would be something like:
3070 ...they shuffled back towards the rear of the line. 'No, not at the
3071 rear!' the slave-driver shouted. 'Three files up. And stay there...
3073 However, I really needed to violate that tradition just so I could keep
3074 track of what happens myself, not to mention some poor fool trying to
3075 understand this years from now :-).
3078 /* ********************************************************** Configuration */
3080 #ifndef QSORT_ORDER_GUESS
3081 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3084 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3085 future processing - a good max upper bound is log base 2 of memory size
3086 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3087 safely be smaller than that since the program is taking up some space and
3088 most operating systems only let you grab some subset of contiguous
3089 memory (not to mention that you are normally sorting data larger than
3090 1 byte element size :-).
3092 #ifndef QSORT_MAX_STACK
3093 #define QSORT_MAX_STACK 32
3096 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3097 Anything bigger and we use qsort. If you make this too small, the qsort
3098 will probably break (or become less efficient), because it doesn't expect
3099 the middle element of a partition to be the same as the right or left -
3100 you have been warned).
3102 #ifndef QSORT_BREAK_EVEN
3103 #define QSORT_BREAK_EVEN 6
3106 /* ************************************************************* Data Types */
3108 /* hold left and right index values of a partition waiting to be sorted (the
3109 partition includes both left and right - right is NOT one past the end or
3110 anything like that).
3112 struct partition_stack_entry {
3115 #ifdef QSORT_ORDER_GUESS
3116 int qsort_break_even;
3120 /* ******************************************************* Shorthand Macros */
3122 /* Note that these macros will be used from inside the qsort function where
3123 we happen to know that the variable 'elt_size' contains the size of an
3124 array element and the variable 'temp' points to enough space to hold a
3125 temp element and the variable 'array' points to the array being sorted
3126 and 'compare' is the pointer to the compare routine.
3128 Also note that there are very many highly architecture specific ways
3129 these might be sped up, but this is simply the most generally portable
3130 code I could think of.
3133 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3136 #define qsort_cmp(elt1, elt2) \
3137 ((this->*compare)(array[elt1], array[elt2]))
3139 #define qsort_cmp(elt1, elt2) \
3140 ((*compare)(array[elt1], array[elt2]))
3143 #ifdef QSORT_ORDER_GUESS
3144 #define QSORT_NOTICE_SWAP swapped++;
3146 #define QSORT_NOTICE_SWAP
3149 /* swaps contents of array elements elt1, elt2.
3151 #define qsort_swap(elt1, elt2) \
3154 temp = array[elt1]; \
3155 array[elt1] = array[elt2]; \
3156 array[elt2] = temp; \
3159 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3160 elt3 and elt3 gets elt1.
3162 #define qsort_rotate(elt1, elt2, elt3) \
3165 temp = array[elt1]; \
3166 array[elt1] = array[elt2]; \
3167 array[elt2] = array[elt3]; \
3168 array[elt3] = temp; \
3171 /* ************************************************************ Debug stuff */
3178 return; /* good place to set a breakpoint */
3181 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3184 doqsort_all_asserts(
3188 int (*compare)(const void * elt1, const void * elt2),
3189 int pc_left, int pc_right, int u_left, int u_right)
3193 qsort_assert(pc_left <= pc_right);
3194 qsort_assert(u_right < pc_left);
3195 qsort_assert(pc_right < u_left);
3196 for (i = u_right + 1; i < pc_left; ++i) {
3197 qsort_assert(qsort_cmp(i, pc_left) < 0);
3199 for (i = pc_left; i < pc_right; ++i) {
3200 qsort_assert(qsort_cmp(i, pc_right) == 0);
3202 for (i = pc_right + 1; i < u_left; ++i) {
3203 qsort_assert(qsort_cmp(pc_right, i) < 0);
3207 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3208 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3209 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3213 #define qsort_assert(t) ((void)0)
3215 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3219 /* ****************************************************************** qsort */
3223 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3228 I32 (*compare)(SV *a, SV *b))
3233 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3234 int next_stack_entry = 0;
3238 #ifdef QSORT_ORDER_GUESS
3239 int qsort_break_even;
3243 /* Make sure we actually have work to do.
3245 if (num_elts <= 1) {
3249 /* Setup the initial partition definition and fall into the sorting loop
3252 part_right = (int)(num_elts - 1);
3253 #ifdef QSORT_ORDER_GUESS
3254 qsort_break_even = QSORT_BREAK_EVEN;
3256 #define qsort_break_even QSORT_BREAK_EVEN
3259 if ((part_right - part_left) >= qsort_break_even) {
3260 /* OK, this is gonna get hairy, so lets try to document all the
3261 concepts and abbreviations and variables and what they keep
3264 pc: pivot chunk - the set of array elements we accumulate in the
3265 middle of the partition, all equal in value to the original
3266 pivot element selected. The pc is defined by:
3268 pc_left - the leftmost array index of the pc
3269 pc_right - the rightmost array index of the pc
3271 we start with pc_left == pc_right and only one element
3272 in the pivot chunk (but it can grow during the scan).
3274 u: uncompared elements - the set of elements in the partition
3275 we have not yet compared to the pivot value. There are two
3276 uncompared sets during the scan - one to the left of the pc
3277 and one to the right.
3279 u_right - the rightmost index of the left side's uncompared set
3280 u_left - the leftmost index of the right side's uncompared set
3282 The leftmost index of the left sides's uncompared set
3283 doesn't need its own variable because it is always defined
3284 by the leftmost edge of the whole partition (part_left). The
3285 same goes for the rightmost edge of the right partition
3288 We know there are no uncompared elements on the left once we
3289 get u_right < part_left and no uncompared elements on the
3290 right once u_left > part_right. When both these conditions
3291 are met, we have completed the scan of the partition.
3293 Any elements which are between the pivot chunk and the
3294 uncompared elements should be less than the pivot value on
3295 the left side and greater than the pivot value on the right
3296 side (in fact, the goal of the whole algorithm is to arrange
3297 for that to be true and make the groups of less-than and
3298 greater-then elements into new partitions to sort again).
3300 As you marvel at the complexity of the code and wonder why it
3301 has to be so confusing. Consider some of the things this level
3302 of confusion brings:
3304 Once I do a compare, I squeeze every ounce of juice out of it. I
3305 never do compare calls I don't have to do, and I certainly never
3308 I also never swap any elements unless I can prove there is a
3309 good reason. Many sort algorithms will swap a known value with
3310 an uncompared value just to get things in the right place (or
3311 avoid complexity :-), but that uncompared value, once it gets
3312 compared, may then have to be swapped again. A lot of the
3313 complexity of this code is due to the fact that it never swaps
3314 anything except compared values, and it only swaps them when the
3315 compare shows they are out of position.
3317 int pc_left, pc_right;
3318 int u_right, u_left;
3322 pc_left = ((part_left + part_right) / 2);
3324 u_right = pc_left - 1;
3325 u_left = pc_right + 1;
3327 /* Qsort works best when the pivot value is also the median value
3328 in the partition (unfortunately you can't find the median value
3329 without first sorting :-), so to give the algorithm a helping
3330 hand, we pick 3 elements and sort them and use the median value
3331 of that tiny set as the pivot value.
3333 Some versions of qsort like to use the left middle and right as
3334 the 3 elements to sort so they can insure the ends of the
3335 partition will contain values which will stop the scan in the
3336 compare loop, but when you have to call an arbitrarily complex
3337 routine to do a compare, its really better to just keep track of
3338 array index values to know when you hit the edge of the
3339 partition and avoid the extra compare. An even better reason to
3340 avoid using a compare call is the fact that you can drop off the
3341 edge of the array if someone foolishly provides you with an
3342 unstable compare function that doesn't always provide consistent
3345 So, since it is simpler for us to compare the three adjacent
3346 elements in the middle of the partition, those are the ones we
3347 pick here (conveniently pointed at by u_right, pc_left, and
3348 u_left). The values of the left, center, and right elements
3349 are refered to as l c and r in the following comments.
3352 #ifdef QSORT_ORDER_GUESS
3355 s = qsort_cmp(u_right, pc_left);
3358 s = qsort_cmp(pc_left, u_left);
3359 /* if l < c, c < r - already in order - nothing to do */
3361 /* l < c, c == r - already in order, pc grows */
3363 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3365 /* l < c, c > r - need to know more */
3366 s = qsort_cmp(u_right, u_left);
3368 /* l < c, c > r, l < r - swap c & r to get ordered */
3369 qsort_swap(pc_left, u_left);
3370 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3371 } else if (s == 0) {
3372 /* l < c, c > r, l == r - swap c&r, grow pc */
3373 qsort_swap(pc_left, u_left);
3375 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3377 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3378 qsort_rotate(pc_left, u_right, u_left);
3379 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3382 } else if (s == 0) {
3384 s = qsort_cmp(pc_left, u_left);
3386 /* l == c, c < r - already in order, grow pc */
3388 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3389 } else if (s == 0) {
3390 /* l == c, c == r - already in order, grow pc both ways */
3393 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3395 /* l == c, c > r - swap l & r, grow pc */
3396 qsort_swap(u_right, u_left);
3398 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3402 s = qsort_cmp(pc_left, u_left);
3404 /* l > c, c < r - need to know more */
3405 s = qsort_cmp(u_right, u_left);
3407 /* l > c, c < r, l < r - swap l & c to get ordered */
3408 qsort_swap(u_right, pc_left);
3409 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3410 } else if (s == 0) {
3411 /* l > c, c < r, l == r - swap l & c, grow pc */
3412 qsort_swap(u_right, pc_left);
3414 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3416 /* l > c, c < r, l > r - rotate lcr into crl to order */
3417 qsort_rotate(u_right, pc_left, u_left);
3418 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3420 } else if (s == 0) {
3421 /* l > c, c == r - swap ends, grow pc */
3422 qsort_swap(u_right, u_left);
3424 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3426 /* l > c, c > r - swap ends to get in order */
3427 qsort_swap(u_right, u_left);
3428 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3431 /* We now know the 3 middle elements have been compared and
3432 arranged in the desired order, so we can shrink the uncompared
3437 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3439 /* The above massive nested if was the simple part :-). We now have
3440 the middle 3 elements ordered and we need to scan through the
3441 uncompared sets on either side, swapping elements that are on
3442 the wrong side or simply shuffling equal elements around to get
3443 all equal elements into the pivot chunk.
3447 int still_work_on_left;
3448 int still_work_on_right;
3450 /* Scan the uncompared values on the left. If I find a value
3451 equal to the pivot value, move it over so it is adjacent to
3452 the pivot chunk and expand the pivot chunk. If I find a value
3453 less than the pivot value, then just leave it - its already
3454 on the correct side of the partition. If I find a greater
3455 value, then stop the scan.
3457 while (still_work_on_left = (u_right >= part_left)) {
3458 s = qsort_cmp(u_right, pc_left);
3461 } else if (s == 0) {
3463 if (pc_left != u_right) {
3464 qsort_swap(u_right, pc_left);
3470 qsort_assert(u_right < pc_left);
3471 qsort_assert(pc_left <= pc_right);
3472 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3473 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3476 /* Do a mirror image scan of uncompared values on the right
3478 while (still_work_on_right = (u_left <= part_right)) {
3479 s = qsort_cmp(pc_right, u_left);
3482 } else if (s == 0) {
3484 if (pc_right != u_left) {
3485 qsort_swap(pc_right, u_left);
3491 qsort_assert(u_left > pc_right);
3492 qsort_assert(pc_left <= pc_right);
3493 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3494 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3497 if (still_work_on_left) {
3498 /* I know I have a value on the left side which needs to be
3499 on the right side, but I need to know more to decide
3500 exactly the best thing to do with it.
3502 if (still_work_on_right) {
3503 /* I know I have values on both side which are out of
3504 position. This is a big win because I kill two birds
3505 with one swap (so to speak). I can advance the
3506 uncompared pointers on both sides after swapping both
3507 of them into the right place.
3509 qsort_swap(u_right, u_left);
3512 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3514 /* I have an out of position value on the left, but the
3515 right is fully scanned, so I "slide" the pivot chunk
3516 and any less-than values left one to make room for the
3517 greater value over on the right. If the out of position
3518 value is immediately adjacent to the pivot chunk (there
3519 are no less-than values), I can do that with a swap,
3520 otherwise, I have to rotate one of the less than values
3521 into the former position of the out of position value
3522 and the right end of the pivot chunk into the left end
3526 if (pc_left == u_right) {
3527 qsort_swap(u_right, pc_right);
3528 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3530 qsort_rotate(u_right, pc_left, pc_right);
3531 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3536 } else if (still_work_on_right) {
3537 /* Mirror image of complex case above: I have an out of
3538 position value on the right, but the left is fully
3539 scanned, so I need to shuffle things around to make room
3540 for the right value on the left.
3543 if (pc_right == u_left) {
3544 qsort_swap(u_left, pc_left);
3545 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3547 qsort_rotate(pc_right, pc_left, u_left);
3548 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3553 /* No more scanning required on either side of partition,
3554 break out of loop and figure out next set of partitions
3560 /* The elements in the pivot chunk are now in the right place. They
3561 will never move or be compared again. All I have to do is decide
3562 what to do with the stuff to the left and right of the pivot
3565 Notes on the QSORT_ORDER_GUESS ifdef code:
3567 1. If I just built these partitions without swapping any (or
3568 very many) elements, there is a chance that the elements are
3569 already ordered properly (being properly ordered will
3570 certainly result in no swapping, but the converse can't be
3573 2. A (properly written) insertion sort will run faster on
3574 already ordered data than qsort will.
3576 3. Perhaps there is some way to make a good guess about
3577 switching to an insertion sort earlier than partition size 6
3578 (for instance - we could save the partition size on the stack
3579 and increase the size each time we find we didn't swap, thus
3580 switching to insertion sort earlier for partitions with a
3581 history of not swapping).
3583 4. Naturally, if I just switch right away, it will make
3584 artificial benchmarks with pure ascending (or descending)
3585 data look really good, but is that a good reason in general?
3589 #ifdef QSORT_ORDER_GUESS
3591 #if QSORT_ORDER_GUESS == 1
3592 qsort_break_even = (part_right - part_left) + 1;
3594 #if QSORT_ORDER_GUESS == 2
3595 qsort_break_even *= 2;
3597 #if QSORT_ORDER_GUESS == 3
3598 int prev_break = qsort_break_even;
3599 qsort_break_even *= qsort_break_even;
3600 if (qsort_break_even < prev_break) {
3601 qsort_break_even = (part_right - part_left) + 1;
3605 qsort_break_even = QSORT_BREAK_EVEN;
3609 if (part_left < pc_left) {
3610 /* There are elements on the left which need more processing.
3611 Check the right as well before deciding what to do.
3613 if (pc_right < part_right) {
3614 /* We have two partitions to be sorted. Stack the biggest one
3615 and process the smallest one on the next iteration. This
3616 minimizes the stack height by insuring that any additional
3617 stack entries must come from the smallest partition which
3618 (because it is smallest) will have the fewest
3619 opportunities to generate additional stack entries.
3621 if ((part_right - pc_right) > (pc_left - part_left)) {
3622 /* stack the right partition, process the left */
3623 partition_stack[next_stack_entry].left = pc_right + 1;
3624 partition_stack[next_stack_entry].right = part_right;
3625 #ifdef QSORT_ORDER_GUESS
3626 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3628 part_right = pc_left - 1;
3630 /* stack the left partition, process the right */
3631 partition_stack[next_stack_entry].left = part_left;
3632 partition_stack[next_stack_entry].right = pc_left - 1;
3633 #ifdef QSORT_ORDER_GUESS
3634 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3636 part_left = pc_right + 1;
3638 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3641 /* The elements on the left are the only remaining elements
3642 that need sorting, arrange for them to be processed as the
3645 part_right = pc_left - 1;
3647 } else if (pc_right < part_right) {
3648 /* There is only one chunk on the right to be sorted, make it
3649 the new partition and loop back around.
3651 part_left = pc_right + 1;
3653 /* This whole partition wound up in the pivot chunk, so
3654 we need to get a new partition off the stack.
3656 if (next_stack_entry == 0) {
3657 /* the stack is empty - we are done */
3661 part_left = partition_stack[next_stack_entry].left;
3662 part_right = partition_stack[next_stack_entry].right;
3663 #ifdef QSORT_ORDER_GUESS
3664 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3668 /* This partition is too small to fool with qsort complexity, just
3669 do an ordinary insertion sort to minimize overhead.
3672 /* Assume 1st element is in right place already, and start checking
3673 at 2nd element to see where it should be inserted.
3675 for (i = part_left + 1; i <= part_right; ++i) {
3677 /* Scan (backwards - just in case 'i' is already in right place)
3678 through the elements already sorted to see if the ith element
3679 belongs ahead of one of them.
3681 for (j = i - 1; j >= part_left; --j) {
3682 if (qsort_cmp(i, j) >= 0) {
3683 /* i belongs right after j
3690 /* Looks like we really need to move some things
3694 for (k = i - 1; k >= j; --k)
3695 array[k + 1] = array[k];
3700 /* That partition is now sorted, grab the next one, or get out
3701 of the loop if there aren't any more.
3704 if (next_stack_entry == 0) {
3705 /* the stack is empty - we are done */
3709 part_left = partition_stack[next_stack_entry].left;
3710 part_right = partition_stack[next_stack_entry].right;
3711 #ifdef QSORT_ORDER_GUESS
3712 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3717 /* Believe it or not, the array is sorted at this point! */