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);
290 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
292 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
293 SvREADONLY_off(tmpForm);
294 doparseform(tmpForm);
297 SvPV_force(PL_formtarget, len);
298 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
300 f = SvPV(tmpForm, len);
301 /* need to jump to the next word */
302 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
311 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
312 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
313 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
314 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
315 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
317 case FF_CHECKNL: name = "CHECKNL"; break;
318 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
319 case FF_SPACE: name = "SPACE"; break;
320 case FF_HALFSPACE: name = "HALFSPACE"; break;
321 case FF_ITEM: name = "ITEM"; break;
322 case FF_CHOP: name = "CHOP"; break;
323 case FF_LINEGLOB: name = "LINEGLOB"; break;
324 case FF_NEWLINE: name = "NEWLINE"; break;
325 case FF_MORE: name = "MORE"; break;
326 case FF_LINEMARK: name = "LINEMARK"; break;
327 case FF_END: name = "END"; break;
330 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
332 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
360 if (ckWARN(WARN_SYNTAX))
361 warner(WARN_SYNTAX, "Not enough format arguments");
366 item = s = SvPV(sv, len);
369 itemsize = sv_len_utf8(sv);
370 if (itemsize != len) {
372 if (itemsize > fieldsize) {
373 itemsize = fieldsize;
374 itembytes = itemsize;
375 sv_pos_u2b(sv, &itembytes, 0);
379 send = chophere = s + itembytes;
388 sv_pos_b2u(sv, &itemsize);
392 if (itemsize > fieldsize)
393 itemsize = fieldsize;
394 send = chophere = s + itemsize;
406 item = s = SvPV(sv, len);
409 itemsize = sv_len_utf8(sv);
410 if (itemsize != len) {
412 if (itemsize <= fieldsize) {
413 send = chophere = s + itemsize;
424 itemsize = fieldsize;
425 itembytes = itemsize;
426 sv_pos_u2b(sv, &itembytes, 0);
427 send = chophere = s + itembytes;
428 while (s < send || (s == send && isSPACE(*s))) {
438 if (strchr(PL_chopset, *s))
443 itemsize = chophere - item;
444 sv_pos_b2u(sv, &itemsize);
449 if (itemsize <= fieldsize) {
450 send = chophere = s + itemsize;
461 itemsize = fieldsize;
462 send = chophere = s + itemsize;
463 while (s < send || (s == send && isSPACE(*s))) {
473 if (strchr(PL_chopset, *s))
478 itemsize = chophere - item;
483 arg = fieldsize - itemsize;
492 arg = fieldsize - itemsize;
507 switch (UTF8SKIP(s)) {
518 if ( !((*t++ = *s++) & ~31) )
526 int ch = *t++ = *s++;
529 if ( !((*t++ = *s++) & ~31) )
538 while (*s && isSPACE(*s))
545 item = s = SvPV(sv, len);
558 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
559 sv_catpvn(PL_formtarget, item, itemsize);
560 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
561 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
566 /* If the field is marked with ^ and the value is undefined,
569 if ((arg & 512) && !SvOK(sv)) {
577 /* Formats aren't yet marked for locales, so assume "yes". */
580 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
582 sprintf(t, "%*.0f", (int) fieldsize, value);
589 while (t-- > linemark && *t == ' ') ;
597 if (arg) { /* repeat until fields exhausted? */
599 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
600 lines += FmLINES(PL_formtarget);
603 if (strnEQ(linemark, linemark - arg, arg))
604 DIE("Runaway format");
606 FmLINES(PL_formtarget) = lines;
608 RETURNOP(cLISTOP->op_first);
619 arg = fieldsize - itemsize;
626 if (strnEQ(s," ",3)) {
627 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
638 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
639 FmLINES(PL_formtarget) += lines;
651 if (PL_stack_base + *PL_markstack_ptr == SP) {
653 if (GIMME_V == G_SCALAR)
655 RETURNOP(PL_op->op_next->op_next);
657 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
658 pp_pushmark(ARGS); /* push dst */
659 pp_pushmark(ARGS); /* push src */
660 ENTER; /* enter outer scope */
664 /* SAVE_DEFSV does *not* suffice here */
665 save_sptr(&THREADSV(0));
667 SAVESPTR(GvSV(PL_defgv));
668 #endif /* USE_THREADS */
669 ENTER; /* enter inner scope */
672 src = PL_stack_base[*PL_markstack_ptr];
677 if (PL_op->op_type == OP_MAPSTART)
678 pp_pushmark(ARGS); /* push top */
679 return ((LOGOP*)PL_op->op_next)->op_other;
684 DIE("panic: mapstart"); /* uses grepstart */
690 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
696 ++PL_markstack_ptr[-1];
698 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
699 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
700 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
705 PL_markstack_ptr[-1] += shift;
706 *PL_markstack_ptr += shift;
710 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
713 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
715 LEAVE; /* exit inner scope */
718 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
722 (void)POPMARK; /* pop top */
723 LEAVE; /* exit outer scope */
724 (void)POPMARK; /* pop src */
725 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
726 (void)POPMARK; /* pop dst */
727 SP = PL_stack_base + POPMARK; /* pop original mark */
728 if (gimme == G_SCALAR) {
732 else if (gimme == G_ARRAY)
739 ENTER; /* enter inner scope */
742 src = PL_stack_base[PL_markstack_ptr[-1]];
746 RETURNOP(cLOGOP->op_other);
752 djSP; dMARK; dORIGMARK;
754 SV **myorigmark = ORIGMARK;
760 OP* nextop = PL_op->op_next;
762 if (gimme != G_ARRAY) {
768 SAVEPPTR(PL_sortcop);
769 if (PL_op->op_flags & OPf_STACKED) {
770 if (PL_op->op_flags & OPf_SPECIAL) {
771 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
772 kid = kUNOP->op_first; /* pass rv2gv */
773 kid = kUNOP->op_first; /* pass leave */
774 PL_sortcop = kid->op_next;
775 stash = PL_curcop->cop_stash;
778 cv = sv_2cv(*++MARK, &stash, &gv, 0);
779 if (!(cv && CvROOT(cv))) {
781 SV *tmpstr = sv_newmortal();
782 gv_efullname3(tmpstr, gv, Nullch);
783 if (cv && CvXSUB(cv))
784 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
785 DIE("Undefined sort subroutine \"%s\" called",
790 DIE("Xsub called in sort");
791 DIE("Undefined subroutine in sort");
793 DIE("Not a CODE reference in sort");
795 PL_sortcop = CvSTART(cv);
796 SAVESPTR(CvROOT(cv)->op_ppaddr);
797 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
800 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
805 stash = PL_curcop->cop_stash;
809 while (MARK < SP) { /* This may or may not shift down one here. */
811 if (*up = *++MARK) { /* Weed out nulls. */
813 if (!PL_sortcop && !SvPOK(*up))
814 (void)sv_2pv(*up, &PL_na);
818 max = --up - myorigmark;
823 bool oldcatch = CATCH_GET;
829 PUSHSTACKi(PERLSI_SORT);
830 if (PL_sortstash != stash) {
831 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
832 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
833 PL_sortstash = stash;
836 SAVESPTR(GvSV(PL_firstgv));
837 SAVESPTR(GvSV(PL_secondgv));
839 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
840 if (!(PL_op->op_flags & OPf_SPECIAL)) {
841 bool hasargs = FALSE;
842 cx->cx_type = CXt_SUB;
843 cx->blk_gimme = G_SCALAR;
846 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
848 PL_sortcxix = cxstack_ix;
849 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
851 POPBLOCK(cx,PL_curpm);
858 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
859 qsortsv(ORIGMARK+1, max,
860 (PL_op->op_private & OPpLOCALE)
861 ? FUNC_NAME_TO_PTR(sv_cmp_locale)
862 : FUNC_NAME_TO_PTR(sv_cmp));
866 PL_stack_sp = ORIGMARK + max;
874 if (GIMME == G_ARRAY)
875 return cCONDOP->op_true;
876 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
883 if (GIMME == G_ARRAY) {
884 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
888 SV *targ = PAD_SV(PL_op->op_targ);
890 if ((PL_op->op_private & OPpFLIP_LINENUM)
891 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
893 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
894 if (PL_op->op_flags & OPf_SPECIAL) {
902 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
915 if (GIMME == G_ARRAY) {
921 if (SvNIOKp(left) || !SvPOKp(left) ||
922 (looks_like_number(left) && *SvPVX(left) != '0') )
924 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
925 croak("Range iterator outside integer range");
929 EXTEND_MORTAL(max - i + 1);
930 EXTEND(SP, max - i + 1);
933 sv = sv_2mortal(newSViv(i++));
938 SV *final = sv_mortalcopy(right);
940 char *tmps = SvPV(final, len);
942 sv = sv_mortalcopy(left);
943 SvPV_force(sv,PL_na);
944 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
946 if (strEQ(SvPVX(sv),tmps))
948 sv = sv_2mortal(newSVsv(sv));
955 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
957 if ((PL_op->op_private & OPpFLIP_LINENUM)
958 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
960 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
961 sv_catpv(targ, "E0");
972 dopoptolabel(char *label)
976 register PERL_CONTEXT *cx;
978 for (i = cxstack_ix; i >= 0; i--) {
980 switch (CxTYPE(cx)) {
982 if (ckWARN(WARN_UNSAFE))
983 warner(WARN_UNSAFE, "Exiting substitution via %s",
984 op_name[PL_op->op_type]);
987 if (ckWARN(WARN_UNSAFE))
988 warner(WARN_UNSAFE, "Exiting subroutine via %s",
989 op_name[PL_op->op_type]);
992 if (ckWARN(WARN_UNSAFE))
993 warner(WARN_UNSAFE, "Exiting eval via %s",
994 op_name[PL_op->op_type]);
997 if (ckWARN(WARN_UNSAFE))
998 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
999 op_name[PL_op->op_type]);
1002 if (!cx->blk_loop.label ||
1003 strNE(label, cx->blk_loop.label) ) {
1004 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1005 (long)i, cx->blk_loop.label));
1008 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1018 I32 gimme = block_gimme();
1019 return (gimme == G_VOID) ? G_SCALAR : gimme;
1028 cxix = dopoptosub(cxstack_ix);
1032 switch (cxstack[cxix].blk_gimme) {
1040 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1047 dopoptosub(I32 startingblock)
1050 return dopoptosub_at(cxstack, startingblock);
1054 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1058 register PERL_CONTEXT *cx;
1059 for (i = startingblock; i >= 0; i--) {
1061 switch (CxTYPE(cx)) {
1066 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1074 dopoptoeval(I32 startingblock)
1078 register PERL_CONTEXT *cx;
1079 for (i = startingblock; i >= 0; i--) {
1081 switch (CxTYPE(cx)) {
1085 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1093 dopoptoloop(I32 startingblock)
1097 register PERL_CONTEXT *cx;
1098 for (i = startingblock; i >= 0; i--) {
1100 switch (CxTYPE(cx)) {
1102 if (ckWARN(WARN_UNSAFE))
1103 warner(WARN_UNSAFE, "Exiting substitution via %s",
1104 op_name[PL_op->op_type]);
1107 if (ckWARN(WARN_UNSAFE))
1108 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1109 op_name[PL_op->op_type]);
1112 if (ckWARN(WARN_UNSAFE))
1113 warner(WARN_UNSAFE, "Exiting eval via %s",
1114 op_name[PL_op->op_type]);
1117 if (ckWARN(WARN_UNSAFE))
1118 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1119 op_name[PL_op->op_type]);
1122 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1133 register PERL_CONTEXT *cx;
1137 while (cxstack_ix > cxix) {
1138 cx = &cxstack[cxstack_ix];
1139 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1140 (long) cxstack_ix, block_type[CxTYPE(cx)]));
1141 /* Note: we don't need to restore the base context info till the end. */
1142 switch (CxTYPE(cx)) {
1145 continue; /* not break */
1163 die_where(char *message)
1168 register PERL_CONTEXT *cx;
1173 if (PL_in_eval & 4) {
1175 STRLEN klen = strlen(message);
1177 svp = hv_fetch(ERRHV, message, klen, TRUE);
1180 static char prefix[] = "\t(in cleanup) ";
1182 sv_upgrade(*svp, SVt_IV);
1183 (void)SvIOK_only(*svp);
1186 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1187 sv_catpvn(err, prefix, sizeof(prefix)-1);
1188 sv_catpvn(err, message, klen);
1194 sv_setpv(ERRSV, message);
1197 message = SvPVx(ERRSV, PL_na);
1199 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1207 if (cxix < cxstack_ix)
1210 POPBLOCK(cx,PL_curpm);
1211 if (CxTYPE(cx) != CXt_EVAL) {
1212 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1217 if (gimme == G_SCALAR)
1218 *++newsp = &PL_sv_undef;
1219 PL_stack_sp = newsp;
1223 if (optype == OP_REQUIRE) {
1224 char* msg = SvPVx(ERRSV, PL_na);
1225 DIE("%s", *msg ? msg : "Compilation failed in require");
1227 return pop_return();
1230 PerlIO_printf(PerlIO_stderr(), "%s",message);
1231 PerlIO_flush(PerlIO_stderr());
1240 if (SvTRUE(left) != SvTRUE(right))
1252 RETURNOP(cLOGOP->op_other);
1261 RETURNOP(cLOGOP->op_other);
1267 register I32 cxix = dopoptosub(cxstack_ix);
1268 register PERL_CONTEXT *cx;
1269 register PERL_CONTEXT *ccstack = cxstack;
1270 PERL_SI *top_si = PL_curstackinfo;
1281 /* we may be in a higher stacklevel, so dig down deeper */
1282 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1283 top_si = top_si->si_prev;
1284 ccstack = top_si->si_cxstack;
1285 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1288 if (GIMME != G_ARRAY)
1292 if (PL_DBsub && cxix >= 0 &&
1293 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1297 cxix = dopoptosub_at(ccstack, cxix - 1);
1300 cx = &ccstack[cxix];
1301 if (CxTYPE(cx) == CXt_SUB) {
1302 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1303 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1304 field below is defined for any cx. */
1305 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1306 cx = &ccstack[dbcxix];
1309 if (GIMME != G_ARRAY) {
1310 hv = cx->blk_oldcop->cop_stash;
1312 PUSHs(&PL_sv_undef);
1315 sv_setpv(TARG, HvNAME(hv));
1321 hv = cx->blk_oldcop->cop_stash;
1323 PUSHs(&PL_sv_undef);
1325 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1326 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1327 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1330 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1332 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1333 PUSHs(sv_2mortal(sv));
1334 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1337 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1338 PUSHs(sv_2mortal(newSViv(0)));
1340 gimme = (I32)cx->blk_gimme;
1341 if (gimme == G_VOID)
1342 PUSHs(&PL_sv_undef);
1344 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1345 if (CxTYPE(cx) == CXt_EVAL) {
1346 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1347 PUSHs(cx->blk_eval.cur_text);
1350 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1351 /* Require, put the name. */
1352 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1356 else if (CxTYPE(cx) == CXt_SUB &&
1357 cx->blk_sub.hasargs &&
1358 PL_curcop->cop_stash == PL_debstash)
1360 AV *ary = cx->blk_sub.argarray;
1361 int off = AvARRAY(ary) - AvALLOC(ary);
1365 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1368 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1371 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1372 av_extend(PL_dbargs, AvFILLp(ary) + off);
1373 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1374 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1380 sortcv(SV *a, SV *b)
1383 I32 oldsaveix = PL_savestack_ix;
1384 I32 oldscopeix = PL_scopestack_ix;
1386 GvSV(PL_firstgv) = a;
1387 GvSV(PL_secondgv) = b;
1388 PL_stack_sp = PL_stack_base;
1391 if (PL_stack_sp != PL_stack_base + 1)
1392 croak("Sort subroutine didn't return single value");
1393 if (!SvNIOKp(*PL_stack_sp))
1394 croak("Sort subroutine didn't return a numeric value");
1395 result = SvIV(*PL_stack_sp);
1396 while (PL_scopestack_ix > oldscopeix) {
1399 leave_scope(oldsaveix);
1412 sv_reset(tmps, PL_curcop->cop_stash);
1424 PL_curcop = (COP*)PL_op;
1425 TAINT_NOT; /* Each statement is presumed innocent */
1426 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1429 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1433 register PERL_CONTEXT *cx;
1434 I32 gimme = G_ARRAY;
1441 DIE("No DB::DB routine defined");
1443 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1455 push_return(PL_op->op_next);
1456 PUSHBLOCK(cx, CXt_SUB, SP);
1459 (void)SvREFCNT_inc(cv);
1460 SAVESPTR(PL_curpad);
1461 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1462 RETURNOP(CvSTART(cv));
1476 register PERL_CONTEXT *cx;
1477 I32 gimme = GIMME_V;
1484 if (PL_op->op_flags & OPf_SPECIAL)
1485 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1487 #endif /* USE_THREADS */
1488 if (PL_op->op_targ) {
1489 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1494 (void)save_scalar(gv);
1495 svp = &GvSV(gv); /* symbol table variable */
1500 PUSHBLOCK(cx, CXt_LOOP, SP);
1501 PUSHLOOP(cx, svp, MARK);
1502 if (PL_op->op_flags & OPf_STACKED) {
1503 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1504 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1506 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1507 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1508 if (SvNV(sv) < IV_MIN ||
1509 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1510 croak("Range iterator outside integer range");
1511 cx->blk_loop.iterix = SvIV(sv);
1512 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1515 cx->blk_loop.iterlval = newSVsv(sv);
1519 cx->blk_loop.iterary = PL_curstack;
1520 AvFILLp(PL_curstack) = SP - PL_stack_base;
1521 cx->blk_loop.iterix = MARK - PL_stack_base;
1530 register PERL_CONTEXT *cx;
1531 I32 gimme = GIMME_V;
1537 PUSHBLOCK(cx, CXt_LOOP, SP);
1538 PUSHLOOP(cx, 0, SP);
1546 register PERL_CONTEXT *cx;
1547 struct block_loop cxloop;
1555 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1558 if (gimme == G_VOID)
1560 else if (gimme == G_SCALAR) {
1562 *++newsp = sv_mortalcopy(*SP);
1564 *++newsp = &PL_sv_undef;
1568 *++newsp = sv_mortalcopy(*++mark);
1569 TAINT_NOT; /* Each item is independent */
1575 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1576 PL_curpm = newpm; /* ... and pop $1 et al */
1588 register PERL_CONTEXT *cx;
1589 struct block_sub cxsub;
1590 bool popsub2 = FALSE;
1596 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1597 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1598 if (cxstack_ix > PL_sortcxix)
1599 dounwind(PL_sortcxix);
1600 AvARRAY(PL_curstack)[1] = *SP;
1601 PL_stack_sp = PL_stack_base + 1;
1606 cxix = dopoptosub(cxstack_ix);
1608 DIE("Can't return outside a subroutine");
1609 if (cxix < cxstack_ix)
1613 switch (CxTYPE(cx)) {
1615 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1620 if (optype == OP_REQUIRE &&
1621 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1623 /* Unassume the success we assumed earlier. */
1624 char *name = cx->blk_eval.old_name;
1625 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1626 DIE("%s did not return a true value", name);
1630 DIE("panic: return");
1634 if (gimme == G_SCALAR) {
1637 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1639 *++newsp = SvREFCNT_inc(*SP);
1644 *++newsp = sv_mortalcopy(*SP);
1647 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1649 *++newsp = sv_mortalcopy(*SP);
1651 *++newsp = &PL_sv_undef;
1653 else if (gimme == G_ARRAY) {
1654 while (++MARK <= SP) {
1655 *++newsp = (popsub2 && SvTEMP(*MARK))
1656 ? *MARK : sv_mortalcopy(*MARK);
1657 TAINT_NOT; /* Each item is independent */
1660 PL_stack_sp = newsp;
1662 /* Stack values are safe: */
1664 POPSUB2(); /* release CV and @_ ... */
1666 PL_curpm = newpm; /* ... and pop $1 et al */
1669 return pop_return();
1676 register PERL_CONTEXT *cx;
1677 struct block_loop cxloop;
1678 struct block_sub cxsub;
1685 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1687 if (PL_op->op_flags & OPf_SPECIAL) {
1688 cxix = dopoptoloop(cxstack_ix);
1690 DIE("Can't \"last\" outside a block");
1693 cxix = dopoptolabel(cPVOP->op_pv);
1695 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1697 if (cxix < cxstack_ix)
1701 switch (CxTYPE(cx)) {
1703 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1705 nextop = cxloop.last_op->op_next;
1708 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1710 nextop = pop_return();
1714 nextop = pop_return();
1721 if (gimme == G_SCALAR) {
1723 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1724 ? *SP : sv_mortalcopy(*SP);
1726 *++newsp = &PL_sv_undef;
1728 else if (gimme == G_ARRAY) {
1729 while (++MARK <= SP) {
1730 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1731 ? *MARK : sv_mortalcopy(*MARK);
1732 TAINT_NOT; /* Each item is independent */
1738 /* Stack values are safe: */
1741 POPLOOP2(); /* release loop vars ... */
1745 POPSUB2(); /* release CV and @_ ... */
1748 PL_curpm = newpm; /* ... and pop $1 et al */
1757 register PERL_CONTEXT *cx;
1760 if (PL_op->op_flags & OPf_SPECIAL) {
1761 cxix = dopoptoloop(cxstack_ix);
1763 DIE("Can't \"next\" outside a block");
1766 cxix = dopoptolabel(cPVOP->op_pv);
1768 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1770 if (cxix < cxstack_ix)
1774 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1775 LEAVE_SCOPE(oldsave);
1776 return cx->blk_loop.next_op;
1782 register PERL_CONTEXT *cx;
1785 if (PL_op->op_flags & OPf_SPECIAL) {
1786 cxix = dopoptoloop(cxstack_ix);
1788 DIE("Can't \"redo\" outside a block");
1791 cxix = dopoptolabel(cPVOP->op_pv);
1793 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1795 if (cxix < cxstack_ix)
1799 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1800 LEAVE_SCOPE(oldsave);
1801 return cx->blk_loop.redo_op;
1805 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1809 static char too_deep[] = "Target of goto is too deeply nested";
1813 if (o->op_type == OP_LEAVE ||
1814 o->op_type == OP_SCOPE ||
1815 o->op_type == OP_LEAVELOOP ||
1816 o->op_type == OP_LEAVETRY)
1818 *ops++ = cUNOPo->op_first;
1823 if (o->op_flags & OPf_KIDS) {
1825 /* First try all the kids at this level, since that's likeliest. */
1826 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1827 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1828 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1831 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1832 if (kid == PL_lastgotoprobe)
1834 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1836 (ops[-1]->op_type != OP_NEXTSTATE &&
1837 ops[-1]->op_type != OP_DBSTATE)))
1839 if (o = dofindlabel(kid, label, ops, oplimit))
1849 return pp_goto(ARGS);
1858 register PERL_CONTEXT *cx;
1859 #define GOTO_DEPTH 64
1860 OP *enterops[GOTO_DEPTH];
1862 int do_dump = (PL_op->op_type == OP_DUMP);
1865 if (PL_op->op_flags & OPf_STACKED) {
1868 /* This egregious kludge implements goto &subroutine */
1869 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1871 register PERL_CONTEXT *cx;
1872 CV* cv = (CV*)SvRV(sv);
1876 int arg_was_real = 0;
1879 if (!CvROOT(cv) && !CvXSUB(cv)) {
1884 /* autoloaded stub? */
1885 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1887 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1888 GvNAMELEN(gv), FALSE);
1889 if (autogv && (cv = GvCV(autogv)))
1891 tmpstr = sv_newmortal();
1892 gv_efullname3(tmpstr, gv, Nullch);
1893 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1895 DIE("Goto undefined subroutine");
1898 /* First do some returnish stuff. */
1899 cxix = dopoptosub(cxstack_ix);
1901 DIE("Can't goto subroutine outside a subroutine");
1902 if (cxix < cxstack_ix)
1905 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1906 DIE("Can't goto subroutine from an eval-string");
1908 if (CxTYPE(cx) == CXt_SUB &&
1909 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1910 AV* av = cx->blk_sub.argarray;
1912 items = AvFILLp(av) + 1;
1914 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1915 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1916 PL_stack_sp += items;
1918 SvREFCNT_dec(GvAV(PL_defgv));
1919 GvAV(PL_defgv) = cx->blk_sub.savearray;
1920 #endif /* USE_THREADS */
1923 AvREAL_off(av); /* so av_clear() won't clobber elts */
1927 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1931 av = (AV*)PL_curpad[0];
1933 av = GvAV(PL_defgv);
1935 items = AvFILLp(av) + 1;
1937 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1938 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1939 PL_stack_sp += items;
1941 if (CxTYPE(cx) == CXt_SUB &&
1942 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1943 SvREFCNT_dec(cx->blk_sub.cv);
1944 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1945 LEAVE_SCOPE(oldsave);
1947 /* Now do some callish stuff. */
1950 if (CvOLDSTYLE(cv)) {
1951 I32 (*fp3)_((int,int,int));
1956 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1957 items = (*fp3)(CvXSUBANY(cv).any_i32,
1958 mark - PL_stack_base + 1,
1960 SP = PL_stack_base + items;
1966 PL_stack_sp--; /* There is no cv arg. */
1967 /* Push a mark for the start of arglist */
1969 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1970 /* Pop the current context like a decent sub should */
1971 POPBLOCK(cx, PL_curpm);
1972 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1975 return pop_return();
1978 AV* padlist = CvPADLIST(cv);
1979 SV** svp = AvARRAY(padlist);
1980 if (CxTYPE(cx) == CXt_EVAL) {
1981 PL_in_eval = cx->blk_eval.old_in_eval;
1982 PL_eval_root = cx->blk_eval.old_eval_root;
1983 cx->cx_type = CXt_SUB;
1984 cx->blk_sub.hasargs = 0;
1986 cx->blk_sub.cv = cv;
1987 cx->blk_sub.olddepth = CvDEPTH(cv);
1989 if (CvDEPTH(cv) < 2)
1990 (void)SvREFCNT_inc(cv);
1991 else { /* save temporaries on recursion? */
1992 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
1993 sub_crush_depth(cv);
1994 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1995 AV *newpad = newAV();
1996 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1997 I32 ix = AvFILLp((AV*)svp[1]);
1998 svp = AvARRAY(svp[0]);
1999 for ( ;ix > 0; ix--) {
2000 if (svp[ix] != &PL_sv_undef) {
2001 char *name = SvPVX(svp[ix]);
2002 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2005 /* outer lexical or anon code */
2006 av_store(newpad, ix,
2007 SvREFCNT_inc(oldpad[ix]) );
2009 else { /* our own lexical */
2011 av_store(newpad, ix, sv = (SV*)newAV());
2012 else if (*name == '%')
2013 av_store(newpad, ix, sv = (SV*)newHV());
2015 av_store(newpad, ix, sv = NEWSV(0,0));
2020 av_store(newpad, ix, sv = NEWSV(0,0));
2024 if (cx->blk_sub.hasargs) {
2027 av_store(newpad, 0, (SV*)av);
2028 AvFLAGS(av) = AVf_REIFY;
2030 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2031 AvFILLp(padlist) = CvDEPTH(cv);
2032 svp = AvARRAY(padlist);
2036 if (!cx->blk_sub.hasargs) {
2037 AV* av = (AV*)PL_curpad[0];
2039 items = AvFILLp(av) + 1;
2041 /* Mark is at the end of the stack. */
2043 Copy(AvARRAY(av), SP + 1, items, SV*);
2048 #endif /* USE_THREADS */
2049 SAVESPTR(PL_curpad);
2050 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2052 if (cx->blk_sub.hasargs)
2053 #endif /* USE_THREADS */
2055 AV* av = (AV*)PL_curpad[0];
2059 cx->blk_sub.savearray = GvAV(PL_defgv);
2060 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2061 #endif /* USE_THREADS */
2062 cx->blk_sub.argarray = av;
2065 if (items >= AvMAX(av) + 1) {
2067 if (AvARRAY(av) != ary) {
2068 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2069 SvPVX(av) = (char*)ary;
2071 if (items >= AvMAX(av) + 1) {
2072 AvMAX(av) = items - 1;
2073 Renew(ary,items+1,SV*);
2075 SvPVX(av) = (char*)ary;
2078 Copy(mark,AvARRAY(av),items,SV*);
2079 AvFILLp(av) = items - 1;
2080 /* preserve @_ nature */
2091 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2093 * We do not care about using sv to call CV;
2094 * it's for informational purposes only.
2096 SV *sv = GvSV(PL_DBsub);
2099 if (PERLDB_SUB_NN) {
2100 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2103 gv_efullname3(sv, CvGV(cv), Nullch);
2106 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2107 PUSHMARK( PL_stack_sp );
2108 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2112 RETURNOP(CvSTART(cv));
2116 label = SvPV(sv,PL_na);
2118 else if (PL_op->op_flags & OPf_SPECIAL) {
2120 DIE("goto must have label");
2123 label = cPVOP->op_pv;
2125 if (label && *label) {
2130 PL_lastgotoprobe = 0;
2132 for (ix = cxstack_ix; ix >= 0; ix--) {
2134 switch (CxTYPE(cx)) {
2136 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2139 gotoprobe = cx->blk_oldcop->op_sibling;
2145 gotoprobe = cx->blk_oldcop->op_sibling;
2147 gotoprobe = PL_main_root;
2150 if (CvDEPTH(cx->blk_sub.cv)) {
2151 gotoprobe = CvROOT(cx->blk_sub.cv);
2156 DIE("Can't \"goto\" outside a block");
2160 gotoprobe = PL_main_root;
2163 retop = dofindlabel(gotoprobe, label,
2164 enterops, enterops + GOTO_DEPTH);
2167 PL_lastgotoprobe = gotoprobe;
2170 DIE("Can't find label %s", label);
2172 /* pop unwanted frames */
2174 if (ix < cxstack_ix) {
2181 oldsave = PL_scopestack[PL_scopestack_ix];
2182 LEAVE_SCOPE(oldsave);
2185 /* push wanted frames */
2187 if (*enterops && enterops[1]) {
2189 for (ix = 1; enterops[ix]; ix++) {
2190 PL_op = enterops[ix];
2191 /* Eventually we may want to stack the needed arguments
2192 * for each op. For now, we punt on the hard ones. */
2193 if (PL_op->op_type == OP_ENTERITER)
2194 DIE("Can't \"goto\" into the middle of a foreach loop",
2196 (CALLOP->op_ppaddr)(ARGS);
2204 if (!retop) retop = PL_main_start;
2206 PL_restartop = retop;
2207 PL_do_undump = TRUE;
2211 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2212 PL_do_undump = FALSE;
2228 if (anum == 1 && VMSISH_EXIT)
2233 PUSHs(&PL_sv_undef);
2241 double value = SvNVx(GvSV(cCOP->cop_gv));
2242 register I32 match = I_32(value);
2245 if (((double)match) > value)
2246 --match; /* was fractional--truncate other way */
2248 match -= cCOP->uop.scop.scop_offset;
2251 else if (match > cCOP->uop.scop.scop_max)
2252 match = cCOP->uop.scop.scop_max;
2253 PL_op = cCOP->uop.scop.scop_next[match];
2263 PL_op = PL_op->op_next; /* can't assume anything */
2265 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2266 match -= cCOP->uop.scop.scop_offset;
2269 else if (match > cCOP->uop.scop.scop_max)
2270 match = cCOP->uop.scop.scop_max;
2271 PL_op = cCOP->uop.scop.scop_next[match];
2280 save_lines(AV *array, SV *sv)
2282 register char *s = SvPVX(sv);
2283 register char *send = SvPVX(sv) + SvCUR(sv);
2285 register I32 line = 1;
2287 while (s && s < send) {
2288 SV *tmpstr = NEWSV(85,0);
2290 sv_upgrade(tmpstr, SVt_PVMG);
2291 t = strchr(s, '\n');
2297 sv_setpvn(tmpstr, s, t - s);
2298 av_store(array, line++, tmpstr);
2313 assert(CATCH_GET == TRUE);
2314 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2318 default: /* topmost level handles it */
2327 PL_op = PL_restartop;
2340 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2341 /* sv Text to convert to OP tree. */
2342 /* startop op_free() this to undo. */
2343 /* code Short string id of the caller. */
2345 dSP; /* Make POPBLOCK work. */
2348 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2351 OP *oop = PL_op, *rop;
2352 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2358 /* switch to eval mode */
2360 if (PL_curcop == &PL_compiling) {
2361 SAVESPTR(PL_compiling.cop_stash);
2362 PL_compiling.cop_stash = PL_curstash;
2364 SAVESPTR(PL_compiling.cop_filegv);
2365 SAVEI16(PL_compiling.cop_line);
2366 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2367 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2368 PL_compiling.cop_line = 1;
2369 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2370 deleting the eval's FILEGV from the stash before gv_check() runs
2371 (i.e. before run-time proper). To work around the coredump that
2372 ensues, we always turn GvMULTI_on for any globals that were
2373 introduced within evals. See force_ident(). GSAR 96-10-12 */
2374 safestr = savepv(tmpbuf);
2375 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2377 #ifdef OP_IN_REGISTER
2385 PL_op->op_type = OP_ENTEREVAL;
2386 PL_op->op_flags = 0; /* Avoid uninit warning. */
2387 PUSHBLOCK(cx, CXt_EVAL, SP);
2388 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2389 rop = doeval(G_SCALAR, startop);
2390 POPBLOCK(cx,PL_curpm);
2393 (*startop)->op_type = OP_NULL;
2394 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2396 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2398 if (PL_curcop == &PL_compiling)
2399 PL_compiling.op_private = PL_hints;
2400 #ifdef OP_IN_REGISTER
2406 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2408 doeval(int gimme, OP** startop)
2421 /* set up a scratch pad */
2424 SAVESPTR(PL_curpad);
2425 SAVESPTR(PL_comppad);
2426 SAVESPTR(PL_comppad_name);
2427 SAVEI32(PL_comppad_name_fill);
2428 SAVEI32(PL_min_intro_pending);
2429 SAVEI32(PL_max_intro_pending);
2432 for (i = cxstack_ix - 1; i >= 0; i--) {
2433 PERL_CONTEXT *cx = &cxstack[i];
2434 if (CxTYPE(cx) == CXt_EVAL)
2436 else if (CxTYPE(cx) == CXt_SUB) {
2437 caller = cx->blk_sub.cv;
2442 SAVESPTR(PL_compcv);
2443 PL_compcv = (CV*)NEWSV(1104,0);
2444 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2445 CvUNIQUE_on(PL_compcv);
2447 CvOWNER(PL_compcv) = 0;
2448 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2449 MUTEX_INIT(CvMUTEXP(PL_compcv));
2450 #endif /* USE_THREADS */
2452 PL_comppad = newAV();
2453 av_push(PL_comppad, Nullsv);
2454 PL_curpad = AvARRAY(PL_comppad);
2455 PL_comppad_name = newAV();
2456 PL_comppad_name_fill = 0;
2457 PL_min_intro_pending = 0;
2460 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2461 PL_curpad[0] = (SV*)newAV();
2462 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2463 #endif /* USE_THREADS */
2465 comppadlist = newAV();
2466 AvREAL_off(comppadlist);
2467 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2468 av_store(comppadlist, 1, (SV*)PL_comppad);
2469 CvPADLIST(PL_compcv) = comppadlist;
2471 if (!saveop || saveop->op_type != OP_REQUIRE)
2472 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2474 SAVEFREESV(PL_compcv);
2476 /* make sure we compile in the right package */
2478 newstash = PL_curcop->cop_stash;
2479 if (PL_curstash != newstash) {
2480 SAVESPTR(PL_curstash);
2481 PL_curstash = newstash;
2483 SAVESPTR(PL_beginav);
2484 PL_beginav = newAV();
2485 SAVEFREESV(PL_beginav);
2487 /* try to compile it */
2489 PL_eval_root = Nullop;
2491 PL_curcop = &PL_compiling;
2492 PL_curcop->cop_arybase = 0;
2493 SvREFCNT_dec(PL_rs);
2494 PL_rs = newSVpv("\n", 1);
2495 if (saveop && saveop->op_flags & OPf_SPECIAL)
2499 if (yyparse() || PL_error_count || !PL_eval_root) {
2503 I32 optype = 0; /* Might be reset by POPEVAL. */
2507 op_free(PL_eval_root);
2508 PL_eval_root = Nullop;
2510 SP = PL_stack_base + POPMARK; /* pop original mark */
2512 POPBLOCK(cx,PL_curpm);
2518 if (optype == OP_REQUIRE) {
2519 char* msg = SvPVx(ERRSV, PL_na);
2520 DIE("%s", *msg ? msg : "Compilation failed in require");
2521 } else if (startop) {
2522 char* msg = SvPVx(ERRSV, PL_na);
2524 POPBLOCK(cx,PL_curpm);
2526 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2528 SvREFCNT_dec(PL_rs);
2529 PL_rs = SvREFCNT_inc(PL_nrs);
2531 MUTEX_LOCK(&PL_eval_mutex);
2533 COND_SIGNAL(&PL_eval_cond);
2534 MUTEX_UNLOCK(&PL_eval_mutex);
2535 #endif /* USE_THREADS */
2538 SvREFCNT_dec(PL_rs);
2539 PL_rs = SvREFCNT_inc(PL_nrs);
2540 PL_compiling.cop_line = 0;
2542 *startop = PL_eval_root;
2543 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2544 CvOUTSIDE(PL_compcv) = Nullcv;
2546 SAVEFREEOP(PL_eval_root);
2548 scalarvoid(PL_eval_root);
2549 else if (gimme & G_ARRAY)
2552 scalar(PL_eval_root);
2554 DEBUG_x(dump_eval());
2556 /* Register with debugger: */
2557 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2558 CV *cv = perl_get_cv("DB::postponed", FALSE);
2562 XPUSHs((SV*)PL_compiling.cop_filegv);
2564 perl_call_sv((SV*)cv, G_DISCARD);
2568 /* compiled okay, so do it */
2570 CvDEPTH(PL_compcv) = 1;
2571 SP = PL_stack_base + POPMARK; /* pop original mark */
2572 PL_op = saveop; /* The caller may need it. */
2574 MUTEX_LOCK(&PL_eval_mutex);
2576 COND_SIGNAL(&PL_eval_cond);
2577 MUTEX_UNLOCK(&PL_eval_mutex);
2578 #endif /* USE_THREADS */
2580 RETURNOP(PL_eval_start);
2586 register PERL_CONTEXT *cx;
2591 SV *namesv = Nullsv;
2593 I32 gimme = G_SCALAR;
2594 PerlIO *tryrsfp = 0;
2597 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2598 SET_NUMERIC_STANDARD();
2599 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2600 DIE("Perl %s required--this is only version %s, stopped",
2601 SvPV(sv,PL_na),PL_patchlevel);
2604 name = SvPV(sv, len);
2605 if (!(name && len > 0 && *name))
2606 DIE("Null filename used");
2607 TAINT_PROPER("require");
2608 if (PL_op->op_type == OP_REQUIRE &&
2609 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2610 *svp != &PL_sv_undef)
2613 /* prepare to compile file */
2618 (name[1] == '.' && name[2] == '/')))
2620 || (name[0] && name[1] == ':')
2623 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2626 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2627 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2632 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2635 AV *ar = GvAVn(PL_incgv);
2639 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2642 namesv = NEWSV(806, 0);
2643 for (i = 0; i <= AvFILL(ar); i++) {
2644 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2647 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2649 sv_setpv(namesv, unixdir);
2650 sv_catpv(namesv, unixname);
2652 sv_setpvf(namesv, "%s/%s", dir, name);
2654 TAINT_PROPER("require");
2655 tryname = SvPVX(namesv);
2656 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2658 if (tryname[0] == '.' && tryname[1] == '/')
2665 SAVESPTR(PL_compiling.cop_filegv);
2666 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2667 SvREFCNT_dec(namesv);
2669 if (PL_op->op_type == OP_REQUIRE) {
2670 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2671 SV *dirmsgsv = NEWSV(0, 0);
2672 AV *ar = GvAVn(PL_incgv);
2674 if (instr(SvPVX(msg), ".h "))
2675 sv_catpv(msg, " (change .h to .ph maybe?)");
2676 if (instr(SvPVX(msg), ".ph "))
2677 sv_catpv(msg, " (did you run h2ph?)");
2678 sv_catpv(msg, " (@INC contains:");
2679 for (i = 0; i <= AvFILL(ar); i++) {
2680 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2681 sv_setpvf(dirmsgsv, " %s", dir);
2682 sv_catsv(msg, dirmsgsv);
2684 sv_catpvn(msg, ")", 1);
2685 SvREFCNT_dec(dirmsgsv);
2692 SETERRNO(0, SS$_NORMAL);
2694 /* Assume success here to prevent recursive requirement. */
2695 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2696 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2700 lex_start(sv_2mortal(newSVpv("",0)));
2701 SAVEGENERICSV(PL_rsfp_filters);
2702 PL_rsfp_filters = Nullav;
2705 name = savepv(name);
2709 SAVEPPTR(PL_compiling.cop_warnings);
2710 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2713 /* switch to eval mode */
2715 push_return(PL_op->op_next);
2716 PUSHBLOCK(cx, CXt_EVAL, SP);
2717 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2719 SAVEI16(PL_compiling.cop_line);
2720 PL_compiling.cop_line = 0;
2724 MUTEX_LOCK(&PL_eval_mutex);
2725 if (PL_eval_owner && PL_eval_owner != thr)
2726 while (PL_eval_owner)
2727 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2728 PL_eval_owner = thr;
2729 MUTEX_UNLOCK(&PL_eval_mutex);
2730 #endif /* USE_THREADS */
2731 return DOCATCH(doeval(G_SCALAR, NULL));
2736 return pp_require(ARGS);
2742 register PERL_CONTEXT *cx;
2744 I32 gimme = GIMME_V, was = PL_sub_generation;
2745 char tmpbuf[TYPE_DIGITS(long) + 12];
2750 if (!SvPV(sv,len) || !len)
2752 TAINT_PROPER("eval");
2758 /* switch to eval mode */
2760 SAVESPTR(PL_compiling.cop_filegv);
2761 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2762 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2763 PL_compiling.cop_line = 1;
2764 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2765 deleting the eval's FILEGV from the stash before gv_check() runs
2766 (i.e. before run-time proper). To work around the coredump that
2767 ensues, we always turn GvMULTI_on for any globals that were
2768 introduced within evals. See force_ident(). GSAR 96-10-12 */
2769 safestr = savepv(tmpbuf);
2770 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2772 PL_hints = PL_op->op_targ;
2773 SAVEPPTR(PL_compiling.cop_warnings);
2774 if (PL_compiling.cop_warnings != WARN_ALL
2775 && PL_compiling.cop_warnings != WARN_NONE){
2776 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2777 SAVEFREESV(PL_compiling.cop_warnings) ;
2780 push_return(PL_op->op_next);
2781 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2782 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2784 /* prepare to compile string */
2786 if (PERLDB_LINE && PL_curstash != PL_debstash)
2787 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2790 MUTEX_LOCK(&PL_eval_mutex);
2791 if (PL_eval_owner && PL_eval_owner != thr)
2792 while (PL_eval_owner)
2793 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2794 PL_eval_owner = thr;
2795 MUTEX_UNLOCK(&PL_eval_mutex);
2796 #endif /* USE_THREADS */
2797 ret = doeval(gimme, NULL);
2798 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2799 && ret != PL_op->op_next) { /* Successive compilation. */
2800 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2802 return DOCATCH(ret);
2812 register PERL_CONTEXT *cx;
2814 U8 save_flags = PL_op -> op_flags;
2819 retop = pop_return();
2822 if (gimme == G_VOID)
2824 else if (gimme == G_SCALAR) {
2827 if (SvFLAGS(TOPs) & SVs_TEMP)
2830 *MARK = sv_mortalcopy(TOPs);
2834 *MARK = &PL_sv_undef;
2838 /* in case LEAVE wipes old return values */
2839 for (mark = newsp + 1; mark <= SP; mark++) {
2840 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2841 *mark = sv_mortalcopy(*mark);
2842 TAINT_NOT; /* Each item is independent */
2846 PL_curpm = newpm; /* Don't pop $1 et al till now */
2849 * Closures mentioned at top level of eval cannot be referenced
2850 * again, and their presence indirectly causes a memory leak.
2851 * (Note that the fact that compcv and friends are still set here
2852 * is, AFAIK, an accident.) --Chip
2854 if (AvFILLp(PL_comppad_name) >= 0) {
2855 SV **svp = AvARRAY(PL_comppad_name);
2857 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2859 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2861 svp[ix] = &PL_sv_undef;
2865 SvREFCNT_dec(CvOUTSIDE(sv));
2866 CvOUTSIDE(sv) = Nullcv;
2879 assert(CvDEPTH(PL_compcv) == 1);
2881 CvDEPTH(PL_compcv) = 0;
2884 if (optype == OP_REQUIRE &&
2885 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2887 /* Unassume the success we assumed earlier. */
2888 char *name = cx->blk_eval.old_name;
2889 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2890 retop = die("%s did not return a true value", name);
2891 /* die_where() did LEAVE, or we won't be here */
2895 if (!(save_flags & OPf_SPECIAL))
2905 register PERL_CONTEXT *cx;
2906 I32 gimme = GIMME_V;
2911 push_return(cLOGOP->op_other->op_next);
2912 PUSHBLOCK(cx, CXt_EVAL, SP);
2914 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2919 return DOCATCH(PL_op->op_next);
2929 register PERL_CONTEXT *cx;
2937 if (gimme == G_VOID)
2939 else if (gimme == G_SCALAR) {
2942 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2945 *MARK = sv_mortalcopy(TOPs);
2949 *MARK = &PL_sv_undef;
2954 /* in case LEAVE wipes old return values */
2955 for (mark = newsp + 1; mark <= SP; mark++) {
2956 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2957 *mark = sv_mortalcopy(*mark);
2958 TAINT_NOT; /* Each item is independent */
2962 PL_curpm = newpm; /* Don't pop $1 et al till now */
2973 register char *s = SvPV_force(sv, len);
2974 register char *send = s + len;
2975 register char *base;
2976 register I32 skipspaces = 0;
2979 bool postspace = FALSE;
2987 croak("Null picture in formline");
2989 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2994 *fpc++ = FF_LINEMARK;
2995 noblank = repeat = FALSE;
3013 case ' ': case '\t':
3024 *fpc++ = FF_LITERAL;
3032 *fpc++ = skipspaces;
3036 *fpc++ = FF_NEWLINE;
3040 arg = fpc - linepc + 1;
3047 *fpc++ = FF_LINEMARK;
3048 noblank = repeat = FALSE;
3057 ischop = s[-1] == '^';
3063 arg = (s - base) - 1;
3065 *fpc++ = FF_LITERAL;
3074 *fpc++ = FF_LINEGLOB;
3076 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3077 arg = ischop ? 512 : 0;
3087 arg |= 256 + (s - f);
3089 *fpc++ = s - base; /* fieldsize for FETCH */
3090 *fpc++ = FF_DECIMAL;
3095 bool ismore = FALSE;
3098 while (*++s == '>') ;
3099 prespace = FF_SPACE;
3101 else if (*s == '|') {
3102 while (*++s == '|') ;
3103 prespace = FF_HALFSPACE;
3108 while (*++s == '<') ;
3111 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3115 *fpc++ = s - base; /* fieldsize for FETCH */
3117 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3135 { /* need to jump to the next word */
3137 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3138 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3139 s = SvPVX(sv) + SvCUR(sv) + z;
3141 Copy(fops, s, arg, U16);
3143 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3148 * The rest of this file was derived from source code contributed
3151 * NOTE: this code was derived from Tom Horsley's qsort replacement
3152 * and should not be confused with the original code.
3155 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3157 Permission granted to distribute under the same terms as perl which are
3160 This program is free software; you can redistribute it and/or modify
3161 it under the terms of either:
3163 a) the GNU General Public License as published by the Free
3164 Software Foundation; either version 1, or (at your option) any
3167 b) the "Artistic License" which comes with this Kit.
3169 Details on the perl license can be found in the perl source code which
3170 may be located via the www.perl.com web page.
3172 This is the most wonderfulest possible qsort I can come up with (and
3173 still be mostly portable) My (limited) tests indicate it consistently
3174 does about 20% fewer calls to compare than does the qsort in the Visual
3175 C++ library, other vendors may vary.
3177 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3178 others I invented myself (or more likely re-invented since they seemed
3179 pretty obvious once I watched the algorithm operate for a while).
3181 Most of this code was written while watching the Marlins sweep the Giants
3182 in the 1997 National League Playoffs - no Braves fans allowed to use this
3183 code (just kidding :-).
3185 I realize that if I wanted to be true to the perl tradition, the only
3186 comment in this file would be something like:
3188 ...they shuffled back towards the rear of the line. 'No, not at the
3189 rear!' the slave-driver shouted. 'Three files up. And stay there...
3191 However, I really needed to violate that tradition just so I could keep
3192 track of what happens myself, not to mention some poor fool trying to
3193 understand this years from now :-).
3196 /* ********************************************************** Configuration */
3198 #ifndef QSORT_ORDER_GUESS
3199 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3202 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3203 future processing - a good max upper bound is log base 2 of memory size
3204 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3205 safely be smaller than that since the program is taking up some space and
3206 most operating systems only let you grab some subset of contiguous
3207 memory (not to mention that you are normally sorting data larger than
3208 1 byte element size :-).
3210 #ifndef QSORT_MAX_STACK
3211 #define QSORT_MAX_STACK 32
3214 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3215 Anything bigger and we use qsort. If you make this too small, the qsort
3216 will probably break (or become less efficient), because it doesn't expect
3217 the middle element of a partition to be the same as the right or left -
3218 you have been warned).
3220 #ifndef QSORT_BREAK_EVEN
3221 #define QSORT_BREAK_EVEN 6
3224 /* ************************************************************* Data Types */
3226 /* hold left and right index values of a partition waiting to be sorted (the
3227 partition includes both left and right - right is NOT one past the end or
3228 anything like that).
3230 struct partition_stack_entry {
3233 #ifdef QSORT_ORDER_GUESS
3234 int qsort_break_even;
3238 /* ******************************************************* Shorthand Macros */
3240 /* Note that these macros will be used from inside the qsort function where
3241 we happen to know that the variable 'elt_size' contains the size of an
3242 array element and the variable 'temp' points to enough space to hold a
3243 temp element and the variable 'array' points to the array being sorted
3244 and 'compare' is the pointer to the compare routine.
3246 Also note that there are very many highly architecture specific ways
3247 these might be sped up, but this is simply the most generally portable
3248 code I could think of.
3251 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3254 #define qsort_cmp(elt1, elt2) \
3255 ((this->*compare)(array[elt1], array[elt2]))
3257 #define qsort_cmp(elt1, elt2) \
3258 ((*compare)(array[elt1], array[elt2]))
3261 #ifdef QSORT_ORDER_GUESS
3262 #define QSORT_NOTICE_SWAP swapped++;
3264 #define QSORT_NOTICE_SWAP
3267 /* swaps contents of array elements elt1, elt2.
3269 #define qsort_swap(elt1, elt2) \
3272 temp = array[elt1]; \
3273 array[elt1] = array[elt2]; \
3274 array[elt2] = temp; \
3277 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3278 elt3 and elt3 gets elt1.
3280 #define qsort_rotate(elt1, elt2, elt3) \
3283 temp = array[elt1]; \
3284 array[elt1] = array[elt2]; \
3285 array[elt2] = array[elt3]; \
3286 array[elt3] = temp; \
3289 /* ************************************************************ Debug stuff */
3296 return; /* good place to set a breakpoint */
3299 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3302 doqsort_all_asserts(
3306 int (*compare)(const void * elt1, const void * elt2),
3307 int pc_left, int pc_right, int u_left, int u_right)
3311 qsort_assert(pc_left <= pc_right);
3312 qsort_assert(u_right < pc_left);
3313 qsort_assert(pc_right < u_left);
3314 for (i = u_right + 1; i < pc_left; ++i) {
3315 qsort_assert(qsort_cmp(i, pc_left) < 0);
3317 for (i = pc_left; i < pc_right; ++i) {
3318 qsort_assert(qsort_cmp(i, pc_right) == 0);
3320 for (i = pc_right + 1; i < u_left; ++i) {
3321 qsort_assert(qsort_cmp(pc_right, i) < 0);
3325 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3326 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3327 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3331 #define qsort_assert(t) ((void)0)
3333 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3337 /* ****************************************************************** qsort */
3341 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3346 I32 (*compare)(SV *a, SV *b))
3351 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3352 int next_stack_entry = 0;
3356 #ifdef QSORT_ORDER_GUESS
3357 int qsort_break_even;
3361 /* Make sure we actually have work to do.
3363 if (num_elts <= 1) {
3367 /* Setup the initial partition definition and fall into the sorting loop
3370 part_right = (int)(num_elts - 1);
3371 #ifdef QSORT_ORDER_GUESS
3372 qsort_break_even = QSORT_BREAK_EVEN;
3374 #define qsort_break_even QSORT_BREAK_EVEN
3377 if ((part_right - part_left) >= qsort_break_even) {
3378 /* OK, this is gonna get hairy, so lets try to document all the
3379 concepts and abbreviations and variables and what they keep
3382 pc: pivot chunk - the set of array elements we accumulate in the
3383 middle of the partition, all equal in value to the original
3384 pivot element selected. The pc is defined by:
3386 pc_left - the leftmost array index of the pc
3387 pc_right - the rightmost array index of the pc
3389 we start with pc_left == pc_right and only one element
3390 in the pivot chunk (but it can grow during the scan).
3392 u: uncompared elements - the set of elements in the partition
3393 we have not yet compared to the pivot value. There are two
3394 uncompared sets during the scan - one to the left of the pc
3395 and one to the right.
3397 u_right - the rightmost index of the left side's uncompared set
3398 u_left - the leftmost index of the right side's uncompared set
3400 The leftmost index of the left sides's uncompared set
3401 doesn't need its own variable because it is always defined
3402 by the leftmost edge of the whole partition (part_left). The
3403 same goes for the rightmost edge of the right partition
3406 We know there are no uncompared elements on the left once we
3407 get u_right < part_left and no uncompared elements on the
3408 right once u_left > part_right. When both these conditions
3409 are met, we have completed the scan of the partition.
3411 Any elements which are between the pivot chunk and the
3412 uncompared elements should be less than the pivot value on
3413 the left side and greater than the pivot value on the right
3414 side (in fact, the goal of the whole algorithm is to arrange
3415 for that to be true and make the groups of less-than and
3416 greater-then elements into new partitions to sort again).
3418 As you marvel at the complexity of the code and wonder why it
3419 has to be so confusing. Consider some of the things this level
3420 of confusion brings:
3422 Once I do a compare, I squeeze every ounce of juice out of it. I
3423 never do compare calls I don't have to do, and I certainly never
3426 I also never swap any elements unless I can prove there is a
3427 good reason. Many sort algorithms will swap a known value with
3428 an uncompared value just to get things in the right place (or
3429 avoid complexity :-), but that uncompared value, once it gets
3430 compared, may then have to be swapped again. A lot of the
3431 complexity of this code is due to the fact that it never swaps
3432 anything except compared values, and it only swaps them when the
3433 compare shows they are out of position.
3435 int pc_left, pc_right;
3436 int u_right, u_left;
3440 pc_left = ((part_left + part_right) / 2);
3442 u_right = pc_left - 1;
3443 u_left = pc_right + 1;
3445 /* Qsort works best when the pivot value is also the median value
3446 in the partition (unfortunately you can't find the median value
3447 without first sorting :-), so to give the algorithm a helping
3448 hand, we pick 3 elements and sort them and use the median value
3449 of that tiny set as the pivot value.
3451 Some versions of qsort like to use the left middle and right as
3452 the 3 elements to sort so they can insure the ends of the
3453 partition will contain values which will stop the scan in the
3454 compare loop, but when you have to call an arbitrarily complex
3455 routine to do a compare, its really better to just keep track of
3456 array index values to know when you hit the edge of the
3457 partition and avoid the extra compare. An even better reason to
3458 avoid using a compare call is the fact that you can drop off the
3459 edge of the array if someone foolishly provides you with an
3460 unstable compare function that doesn't always provide consistent
3463 So, since it is simpler for us to compare the three adjacent
3464 elements in the middle of the partition, those are the ones we
3465 pick here (conveniently pointed at by u_right, pc_left, and
3466 u_left). The values of the left, center, and right elements
3467 are refered to as l c and r in the following comments.
3470 #ifdef QSORT_ORDER_GUESS
3473 s = qsort_cmp(u_right, pc_left);
3476 s = qsort_cmp(pc_left, u_left);
3477 /* if l < c, c < r - already in order - nothing to do */
3479 /* l < c, c == r - already in order, pc grows */
3481 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3483 /* l < c, c > r - need to know more */
3484 s = qsort_cmp(u_right, u_left);
3486 /* l < c, c > r, l < r - swap c & r to get ordered */
3487 qsort_swap(pc_left, u_left);
3488 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3489 } else if (s == 0) {
3490 /* l < c, c > r, l == r - swap c&r, grow pc */
3491 qsort_swap(pc_left, u_left);
3493 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3495 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3496 qsort_rotate(pc_left, u_right, u_left);
3497 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3500 } else if (s == 0) {
3502 s = qsort_cmp(pc_left, u_left);
3504 /* l == c, c < r - already in order, grow pc */
3506 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3507 } else if (s == 0) {
3508 /* l == c, c == r - already in order, grow pc both ways */
3511 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3513 /* l == c, c > r - swap l & r, grow pc */
3514 qsort_swap(u_right, u_left);
3516 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3520 s = qsort_cmp(pc_left, u_left);
3522 /* l > c, c < r - need to know more */
3523 s = qsort_cmp(u_right, u_left);
3525 /* l > c, c < r, l < r - swap l & c to get ordered */
3526 qsort_swap(u_right, pc_left);
3527 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3528 } else if (s == 0) {
3529 /* l > c, c < r, l == r - swap l & c, grow pc */
3530 qsort_swap(u_right, pc_left);
3532 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3534 /* l > c, c < r, l > r - rotate lcr into crl to order */
3535 qsort_rotate(u_right, pc_left, u_left);
3536 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3538 } else if (s == 0) {
3539 /* l > c, c == r - swap ends, grow pc */
3540 qsort_swap(u_right, u_left);
3542 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3544 /* l > c, c > r - swap ends to get in order */
3545 qsort_swap(u_right, u_left);
3546 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3549 /* We now know the 3 middle elements have been compared and
3550 arranged in the desired order, so we can shrink the uncompared
3555 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3557 /* The above massive nested if was the simple part :-). We now have
3558 the middle 3 elements ordered and we need to scan through the
3559 uncompared sets on either side, swapping elements that are on
3560 the wrong side or simply shuffling equal elements around to get
3561 all equal elements into the pivot chunk.
3565 int still_work_on_left;
3566 int still_work_on_right;
3568 /* Scan the uncompared values on the left. If I find a value
3569 equal to the pivot value, move it over so it is adjacent to
3570 the pivot chunk and expand the pivot chunk. If I find a value
3571 less than the pivot value, then just leave it - its already
3572 on the correct side of the partition. If I find a greater
3573 value, then stop the scan.
3575 while (still_work_on_left = (u_right >= part_left)) {
3576 s = qsort_cmp(u_right, pc_left);
3579 } else if (s == 0) {
3581 if (pc_left != u_right) {
3582 qsort_swap(u_right, pc_left);
3588 qsort_assert(u_right < pc_left);
3589 qsort_assert(pc_left <= pc_right);
3590 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3591 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3594 /* Do a mirror image scan of uncompared values on the right
3596 while (still_work_on_right = (u_left <= part_right)) {
3597 s = qsort_cmp(pc_right, u_left);
3600 } else if (s == 0) {
3602 if (pc_right != u_left) {
3603 qsort_swap(pc_right, u_left);
3609 qsort_assert(u_left > pc_right);
3610 qsort_assert(pc_left <= pc_right);
3611 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3612 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3615 if (still_work_on_left) {
3616 /* I know I have a value on the left side which needs to be
3617 on the right side, but I need to know more to decide
3618 exactly the best thing to do with it.
3620 if (still_work_on_right) {
3621 /* I know I have values on both side which are out of
3622 position. This is a big win because I kill two birds
3623 with one swap (so to speak). I can advance the
3624 uncompared pointers on both sides after swapping both
3625 of them into the right place.
3627 qsort_swap(u_right, u_left);
3630 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3632 /* I have an out of position value on the left, but the
3633 right is fully scanned, so I "slide" the pivot chunk
3634 and any less-than values left one to make room for the
3635 greater value over on the right. If the out of position
3636 value is immediately adjacent to the pivot chunk (there
3637 are no less-than values), I can do that with a swap,
3638 otherwise, I have to rotate one of the less than values
3639 into the former position of the out of position value
3640 and the right end of the pivot chunk into the left end
3644 if (pc_left == u_right) {
3645 qsort_swap(u_right, pc_right);
3646 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3648 qsort_rotate(u_right, pc_left, pc_right);
3649 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3654 } else if (still_work_on_right) {
3655 /* Mirror image of complex case above: I have an out of
3656 position value on the right, but the left is fully
3657 scanned, so I need to shuffle things around to make room
3658 for the right value on the left.
3661 if (pc_right == u_left) {
3662 qsort_swap(u_left, pc_left);
3663 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3665 qsort_rotate(pc_right, pc_left, u_left);
3666 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3671 /* No more scanning required on either side of partition,
3672 break out of loop and figure out next set of partitions
3678 /* The elements in the pivot chunk are now in the right place. They
3679 will never move or be compared again. All I have to do is decide
3680 what to do with the stuff to the left and right of the pivot
3683 Notes on the QSORT_ORDER_GUESS ifdef code:
3685 1. If I just built these partitions without swapping any (or
3686 very many) elements, there is a chance that the elements are
3687 already ordered properly (being properly ordered will
3688 certainly result in no swapping, but the converse can't be
3691 2. A (properly written) insertion sort will run faster on
3692 already ordered data than qsort will.
3694 3. Perhaps there is some way to make a good guess about
3695 switching to an insertion sort earlier than partition size 6
3696 (for instance - we could save the partition size on the stack
3697 and increase the size each time we find we didn't swap, thus
3698 switching to insertion sort earlier for partitions with a
3699 history of not swapping).
3701 4. Naturally, if I just switch right away, it will make
3702 artificial benchmarks with pure ascending (or descending)
3703 data look really good, but is that a good reason in general?
3707 #ifdef QSORT_ORDER_GUESS
3709 #if QSORT_ORDER_GUESS == 1
3710 qsort_break_even = (part_right - part_left) + 1;
3712 #if QSORT_ORDER_GUESS == 2
3713 qsort_break_even *= 2;
3715 #if QSORT_ORDER_GUESS == 3
3716 int prev_break = qsort_break_even;
3717 qsort_break_even *= qsort_break_even;
3718 if (qsort_break_even < prev_break) {
3719 qsort_break_even = (part_right - part_left) + 1;
3723 qsort_break_even = QSORT_BREAK_EVEN;
3727 if (part_left < pc_left) {
3728 /* There are elements on the left which need more processing.
3729 Check the right as well before deciding what to do.
3731 if (pc_right < part_right) {
3732 /* We have two partitions to be sorted. Stack the biggest one
3733 and process the smallest one on the next iteration. This
3734 minimizes the stack height by insuring that any additional
3735 stack entries must come from the smallest partition which
3736 (because it is smallest) will have the fewest
3737 opportunities to generate additional stack entries.
3739 if ((part_right - pc_right) > (pc_left - part_left)) {
3740 /* stack the right partition, process the left */
3741 partition_stack[next_stack_entry].left = pc_right + 1;
3742 partition_stack[next_stack_entry].right = part_right;
3743 #ifdef QSORT_ORDER_GUESS
3744 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3746 part_right = pc_left - 1;
3748 /* stack the left partition, process the right */
3749 partition_stack[next_stack_entry].left = part_left;
3750 partition_stack[next_stack_entry].right = pc_left - 1;
3751 #ifdef QSORT_ORDER_GUESS
3752 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3754 part_left = pc_right + 1;
3756 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3759 /* The elements on the left are the only remaining elements
3760 that need sorting, arrange for them to be processed as the
3763 part_right = pc_left - 1;
3765 } else if (pc_right < part_right) {
3766 /* There is only one chunk on the right to be sorted, make it
3767 the new partition and loop back around.
3769 part_left = pc_right + 1;
3771 /* This whole partition wound up in the pivot chunk, so
3772 we need to get a new partition off the stack.
3774 if (next_stack_entry == 0) {
3775 /* the stack is empty - we are done */
3779 part_left = partition_stack[next_stack_entry].left;
3780 part_right = partition_stack[next_stack_entry].right;
3781 #ifdef QSORT_ORDER_GUESS
3782 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3786 /* This partition is too small to fool with qsort complexity, just
3787 do an ordinary insertion sort to minimize overhead.
3790 /* Assume 1st element is in right place already, and start checking
3791 at 2nd element to see where it should be inserted.
3793 for (i = part_left + 1; i <= part_right; ++i) {
3795 /* Scan (backwards - just in case 'i' is already in right place)
3796 through the elements already sorted to see if the ith element
3797 belongs ahead of one of them.
3799 for (j = i - 1; j >= part_left; --j) {
3800 if (qsort_cmp(i, j) >= 0) {
3801 /* i belongs right after j
3808 /* Looks like we really need to move some things
3812 for (k = i - 1; k >= j; --k)
3813 array[k + 1] = array[k];
3818 /* That partition is now sorted, grab the next one, or get out
3819 of the loop if there aren't any more.
3822 if (next_stack_entry == 0) {
3823 /* the stack is empty - we are done */
3827 part_left = partition_stack[next_stack_entry].left;
3828 part_right = partition_stack[next_stack_entry].right;
3829 #ifdef QSORT_ORDER_GUESS
3830 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3835 /* Believe it or not, the array is sorted at this point! */