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));
44 static I32 amagic_cmp _((SV *str1, SV *str2));
45 static I32 amagic_cmp_locale _((SV *str1, SV *str2));
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, 'r');
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
117 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
118 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
119 inside tie/overload accessors. */
123 #ifndef INCOMPLETE_TAINTS
126 pm->op_pmdynflags |= PMdf_TAINTED;
128 pm->op_pmdynflags &= ~PMdf_TAINTED;
132 if (!pm->op_pmregexp->prelen && PL_curpm)
134 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
135 pm->op_pmflags |= PMf_WHITE;
137 if (pm->op_pmflags & PMf_KEEP) {
138 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
139 cLOGOP->op_first->op_next = PL_op->op_next;
147 register PMOP *pm = (PMOP*) cLOGOP->op_other;
148 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
149 register SV *dstr = cx->sb_dstr;
150 register char *s = cx->sb_s;
151 register char *m = cx->sb_m;
152 char *orig = cx->sb_orig;
153 register REGEXP *rx = cx->sb_rx;
155 rxres_restore(&cx->sb_rxres, rx);
157 if (cx->sb_iters++) {
158 if (cx->sb_iters > cx->sb_maxiters)
159 DIE("Substitution loop");
161 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
162 cx->sb_rxtainted |= 2;
163 sv_catsv(dstr, POPs);
166 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
167 s == m, Nullsv, NULL,
168 cx->sb_safebase ? 0 : REXEC_COPY_STR))
170 SV *targ = cx->sb_targ;
171 sv_catpvn(dstr, s, cx->sb_strend - s);
173 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
175 (void)SvOOK_off(targ);
176 Safefree(SvPVX(targ));
177 SvPVX(targ) = SvPVX(dstr);
178 SvCUR_set(targ, SvCUR(dstr));
179 SvLEN_set(targ, SvLEN(dstr));
183 TAINT_IF(cx->sb_rxtainted & 1);
184 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
186 (void)SvPOK_only(targ);
187 TAINT_IF(cx->sb_rxtainted);
191 LEAVE_SCOPE(cx->sb_oldsave);
193 RETURNOP(pm->op_next);
196 if (rx->subbase && rx->subbase != orig) {
199 cx->sb_orig = orig = rx->subbase;
201 cx->sb_strend = s + (cx->sb_strend - m);
203 cx->sb_m = m = rx->startp[0];
204 sv_catpvn(dstr, s, m-s);
205 cx->sb_s = rx->endp[0];
206 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
207 rxres_save(&cx->sb_rxres, rx);
208 RETURNOP(pm->op_pmreplstart);
212 rxres_save(void **rsp, REGEXP *rx)
217 if (!p || p[1] < rx->nparens) {
218 i = 6 + rx->nparens * 2;
226 *p++ = (UV)rx->subbase;
227 rx->subbase = Nullch;
231 *p++ = (UV)rx->subbeg;
232 *p++ = (UV)rx->subend;
233 for (i = 0; i <= rx->nparens; ++i) {
234 *p++ = (UV)rx->startp[i];
235 *p++ = (UV)rx->endp[i];
240 rxres_restore(void **rsp, REGEXP *rx)
245 Safefree(rx->subbase);
246 rx->subbase = (char*)(*p);
251 rx->subbeg = (char*)(*p++);
252 rx->subend = (char*)(*p++);
253 for (i = 0; i <= rx->nparens; ++i) {
254 rx->startp[i] = (char*)(*p++);
255 rx->endp[i] = (char*)(*p++);
260 rxres_free(void **rsp)
265 Safefree((char*)(*p));
273 djSP; dMARK; dORIGMARK;
274 register SV *tmpForm = *++MARK;
286 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
292 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
294 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
295 SvREADONLY_off(tmpForm);
296 doparseform(tmpForm);
299 SvPV_force(PL_formtarget, len);
300 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
302 f = SvPV(tmpForm, len);
303 /* need to jump to the next word */
304 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
313 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
314 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
315 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
316 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
317 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
319 case FF_CHECKNL: name = "CHECKNL"; break;
320 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
321 case FF_SPACE: name = "SPACE"; break;
322 case FF_HALFSPACE: name = "HALFSPACE"; break;
323 case FF_ITEM: name = "ITEM"; break;
324 case FF_CHOP: name = "CHOP"; break;
325 case FF_LINEGLOB: name = "LINEGLOB"; break;
326 case FF_NEWLINE: name = "NEWLINE"; break;
327 case FF_MORE: name = "MORE"; break;
328 case FF_LINEMARK: name = "LINEMARK"; break;
329 case FF_END: name = "END"; break;
332 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
334 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
362 if (ckWARN(WARN_SYNTAX))
363 warner(WARN_SYNTAX, "Not enough format arguments");
368 item = s = SvPV(sv, len);
371 itemsize = sv_len_utf8(sv);
372 if (itemsize != len) {
374 if (itemsize > fieldsize) {
375 itemsize = fieldsize;
376 itembytes = itemsize;
377 sv_pos_u2b(sv, &itembytes, 0);
381 send = chophere = s + itembytes;
390 sv_pos_b2u(sv, &itemsize);
394 if (itemsize > fieldsize)
395 itemsize = fieldsize;
396 send = chophere = s + itemsize;
408 item = s = SvPV(sv, len);
411 itemsize = sv_len_utf8(sv);
412 if (itemsize != len) {
414 if (itemsize <= fieldsize) {
415 send = chophere = s + itemsize;
426 itemsize = fieldsize;
427 itembytes = itemsize;
428 sv_pos_u2b(sv, &itembytes, 0);
429 send = chophere = s + itembytes;
430 while (s < send || (s == send && isSPACE(*s))) {
440 if (strchr(PL_chopset, *s))
445 itemsize = chophere - item;
446 sv_pos_b2u(sv, &itemsize);
451 if (itemsize <= fieldsize) {
452 send = chophere = s + itemsize;
463 itemsize = fieldsize;
464 send = chophere = s + itemsize;
465 while (s < send || (s == send && isSPACE(*s))) {
475 if (strchr(PL_chopset, *s))
480 itemsize = chophere - item;
485 arg = fieldsize - itemsize;
494 arg = fieldsize - itemsize;
509 switch (UTF8SKIP(s)) {
520 if ( !((*t++ = *s++) & ~31) )
528 int ch = *t++ = *s++;
531 if ( !((*t++ = *s++) & ~31) )
540 while (*s && isSPACE(*s))
547 item = s = SvPV(sv, len);
560 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
561 sv_catpvn(PL_formtarget, item, itemsize);
562 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
563 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
568 /* If the field is marked with ^ and the value is undefined,
571 if ((arg & 512) && !SvOK(sv)) {
579 /* Formats aren't yet marked for locales, so assume "yes". */
582 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
584 sprintf(t, "%*.0f", (int) fieldsize, value);
591 while (t-- > linemark && *t == ' ') ;
599 if (arg) { /* repeat until fields exhausted? */
601 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
602 lines += FmLINES(PL_formtarget);
605 if (strnEQ(linemark, linemark - arg, arg))
606 DIE("Runaway format");
608 FmLINES(PL_formtarget) = lines;
610 RETURNOP(cLISTOP->op_first);
621 arg = fieldsize - itemsize;
628 if (strnEQ(s," ",3)) {
629 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
640 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
641 FmLINES(PL_formtarget) += lines;
653 if (PL_stack_base + *PL_markstack_ptr == SP) {
655 if (GIMME_V == G_SCALAR)
657 RETURNOP(PL_op->op_next->op_next);
659 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
660 pp_pushmark(ARGS); /* push dst */
661 pp_pushmark(ARGS); /* push src */
662 ENTER; /* enter outer scope */
666 /* SAVE_DEFSV does *not* suffice here */
667 save_sptr(&THREADSV(0));
669 SAVESPTR(GvSV(PL_defgv));
670 #endif /* USE_THREADS */
671 ENTER; /* enter inner scope */
674 src = PL_stack_base[*PL_markstack_ptr];
679 if (PL_op->op_type == OP_MAPSTART)
680 pp_pushmark(ARGS); /* push top */
681 return ((LOGOP*)PL_op->op_next)->op_other;
686 DIE("panic: mapstart"); /* uses grepstart */
692 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
698 ++PL_markstack_ptr[-1];
700 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
701 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
702 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
707 PL_markstack_ptr[-1] += shift;
708 *PL_markstack_ptr += shift;
712 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
715 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
717 LEAVE; /* exit inner scope */
720 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
724 (void)POPMARK; /* pop top */
725 LEAVE; /* exit outer scope */
726 (void)POPMARK; /* pop src */
727 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
728 (void)POPMARK; /* pop dst */
729 SP = PL_stack_base + POPMARK; /* pop original mark */
730 if (gimme == G_SCALAR) {
734 else if (gimme == G_ARRAY)
741 ENTER; /* enter inner scope */
744 src = PL_stack_base[PL_markstack_ptr[-1]];
748 RETURNOP(cLOGOP->op_other);
752 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
754 if (PL_amagic_generation) { \
755 if (SvAMAGIC(left)||SvAMAGIC(right))\
756 *svp = amagic_call(left, \
764 amagic_cmp(register SV *str1, register SV *str2)
767 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
772 I32 i = SvIVX(tmpsv);
782 return sv_cmp(str1, str2);
786 amagic_cmp_locale(register SV *str1, register SV *str2)
789 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
794 I32 i = SvIVX(tmpsv);
804 return sv_cmp_locale(str1, str2);
809 djSP; dMARK; dORIGMARK;
811 SV **myorigmark = ORIGMARK;
817 OP* nextop = PL_op->op_next;
820 if (gimme != G_ARRAY) {
826 SAVEPPTR(PL_sortcop);
827 if (PL_op->op_flags & OPf_STACKED) {
828 if (PL_op->op_flags & OPf_SPECIAL) {
829 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
830 kid = kUNOP->op_first; /* pass rv2gv */
831 kid = kUNOP->op_first; /* pass leave */
832 PL_sortcop = kid->op_next;
833 stash = PL_curcop->cop_stash;
836 cv = sv_2cv(*++MARK, &stash, &gv, 0);
837 if (!(cv && CvROOT(cv))) {
839 SV *tmpstr = sv_newmortal();
840 gv_efullname3(tmpstr, gv, Nullch);
841 if (cv && CvXSUB(cv))
842 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
843 DIE("Undefined sort subroutine \"%s\" called",
848 DIE("Xsub called in sort");
849 DIE("Undefined subroutine in sort");
851 DIE("Not a CODE reference in sort");
853 PL_sortcop = CvSTART(cv);
854 SAVESPTR(CvROOT(cv)->op_ppaddr);
855 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
858 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
863 stash = PL_curcop->cop_stash;
867 while (MARK < SP) { /* This may or may not shift down one here. */
869 if (*up = *++MARK) { /* Weed out nulls. */
871 if (!PL_sortcop && !SvPOK(*up)) {
875 (void)sv_2pv(*up, &PL_na);
880 max = --up - myorigmark;
885 bool oldcatch = CATCH_GET;
891 PUSHSTACKi(PERLSI_SORT);
892 if (PL_sortstash != stash) {
893 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
894 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
895 PL_sortstash = stash;
898 SAVESPTR(GvSV(PL_firstgv));
899 SAVESPTR(GvSV(PL_secondgv));
901 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
902 if (!(PL_op->op_flags & OPf_SPECIAL)) {
903 bool hasargs = FALSE;
904 cx->cx_type = CXt_SUB;
905 cx->blk_gimme = G_SCALAR;
908 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
910 PL_sortcxix = cxstack_ix;
911 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
913 POPBLOCK(cx,PL_curpm);
920 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
921 qsortsv(ORIGMARK+1, max,
922 (PL_op->op_private & OPpLOCALE)
924 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
925 : FUNC_NAME_TO_PTR(sv_cmp_locale))
927 ? FUNC_NAME_TO_PTR(amagic_cmp)
928 : FUNC_NAME_TO_PTR(sv_cmp) ));
932 PL_stack_sp = ORIGMARK + max;
940 if (GIMME == G_ARRAY)
941 return cCONDOP->op_true;
942 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
949 if (GIMME == G_ARRAY) {
950 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
954 SV *targ = PAD_SV(PL_op->op_targ);
956 if ((PL_op->op_private & OPpFLIP_LINENUM)
957 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
959 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
960 if (PL_op->op_flags & OPf_SPECIAL) {
968 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
981 if (GIMME == G_ARRAY) {
987 if (SvNIOKp(left) || !SvPOKp(left) ||
988 (looks_like_number(left) && *SvPVX(left) != '0') )
990 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
991 croak("Range iterator outside integer range");
995 EXTEND_MORTAL(max - i + 1);
996 EXTEND(SP, max - i + 1);
999 sv = sv_2mortal(newSViv(i++));
1004 SV *final = sv_mortalcopy(right);
1006 char *tmps = SvPV(final, len);
1008 sv = sv_mortalcopy(left);
1009 SvPV_force(sv,PL_na);
1010 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1012 if (strEQ(SvPVX(sv),tmps))
1014 sv = sv_2mortal(newSVsv(sv));
1021 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1023 if ((PL_op->op_private & OPpFLIP_LINENUM)
1024 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1026 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1027 sv_catpv(targ, "E0");
1038 dopoptolabel(char *label)
1042 register PERL_CONTEXT *cx;
1044 for (i = cxstack_ix; i >= 0; i--) {
1046 switch (CxTYPE(cx)) {
1048 if (ckWARN(WARN_UNSAFE))
1049 warner(WARN_UNSAFE, "Exiting substitution via %s",
1050 op_name[PL_op->op_type]);
1053 if (ckWARN(WARN_UNSAFE))
1054 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1055 op_name[PL_op->op_type]);
1058 if (ckWARN(WARN_UNSAFE))
1059 warner(WARN_UNSAFE, "Exiting eval via %s",
1060 op_name[PL_op->op_type]);
1063 if (ckWARN(WARN_UNSAFE))
1064 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1065 op_name[PL_op->op_type]);
1068 if (!cx->blk_loop.label ||
1069 strNE(label, cx->blk_loop.label) ) {
1070 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1071 (long)i, cx->blk_loop.label));
1074 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1084 I32 gimme = block_gimme();
1085 return (gimme == G_VOID) ? G_SCALAR : gimme;
1094 cxix = dopoptosub(cxstack_ix);
1098 switch (cxstack[cxix].blk_gimme) {
1106 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1113 dopoptosub(I32 startingblock)
1116 return dopoptosub_at(cxstack, startingblock);
1120 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1124 register PERL_CONTEXT *cx;
1125 for (i = startingblock; i >= 0; i--) {
1127 switch (CxTYPE(cx)) {
1132 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1140 dopoptoeval(I32 startingblock)
1144 register PERL_CONTEXT *cx;
1145 for (i = startingblock; i >= 0; i--) {
1147 switch (CxTYPE(cx)) {
1151 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1159 dopoptoloop(I32 startingblock)
1163 register PERL_CONTEXT *cx;
1164 for (i = startingblock; i >= 0; i--) {
1166 switch (CxTYPE(cx)) {
1168 if (ckWARN(WARN_UNSAFE))
1169 warner(WARN_UNSAFE, "Exiting substitution via %s",
1170 op_name[PL_op->op_type]);
1173 if (ckWARN(WARN_UNSAFE))
1174 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1175 op_name[PL_op->op_type]);
1178 if (ckWARN(WARN_UNSAFE))
1179 warner(WARN_UNSAFE, "Exiting eval via %s",
1180 op_name[PL_op->op_type]);
1183 if (ckWARN(WARN_UNSAFE))
1184 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1185 op_name[PL_op->op_type]);
1188 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1199 register PERL_CONTEXT *cx;
1203 while (cxstack_ix > cxix) {
1204 cx = &cxstack[cxstack_ix];
1205 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1206 (long) cxstack_ix, block_type[CxTYPE(cx)]));
1207 /* Note: we don't need to restore the base context info till the end. */
1208 switch (CxTYPE(cx)) {
1211 continue; /* not break */
1229 die_where(char *message)
1234 register PERL_CONTEXT *cx;
1239 if (PL_in_eval & 4) {
1241 STRLEN klen = strlen(message);
1243 svp = hv_fetch(ERRHV, message, klen, TRUE);
1246 static char prefix[] = "\t(in cleanup) ";
1248 sv_upgrade(*svp, SVt_IV);
1249 (void)SvIOK_only(*svp);
1252 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1253 sv_catpvn(err, prefix, sizeof(prefix)-1);
1254 sv_catpvn(err, message, klen);
1260 sv_setpv(ERRSV, message);
1263 message = SvPVx(ERRSV, PL_na);
1265 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1273 if (cxix < cxstack_ix)
1276 POPBLOCK(cx,PL_curpm);
1277 if (CxTYPE(cx) != CXt_EVAL) {
1278 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1283 if (gimme == G_SCALAR)
1284 *++newsp = &PL_sv_undef;
1285 PL_stack_sp = newsp;
1289 if (optype == OP_REQUIRE) {
1290 char* msg = SvPVx(ERRSV, PL_na);
1291 DIE("%s", *msg ? msg : "Compilation failed in require");
1293 return pop_return();
1297 message = SvPVx(ERRSV, PL_na);
1298 PerlIO_printf(PerlIO_stderr(), "%s",message);
1299 PerlIO_flush(PerlIO_stderr());
1308 if (SvTRUE(left) != SvTRUE(right))
1320 RETURNOP(cLOGOP->op_other);
1329 RETURNOP(cLOGOP->op_other);
1335 register I32 cxix = dopoptosub(cxstack_ix);
1336 register PERL_CONTEXT *cx;
1337 register PERL_CONTEXT *ccstack = cxstack;
1338 PERL_SI *top_si = PL_curstackinfo;
1349 /* we may be in a higher stacklevel, so dig down deeper */
1350 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1351 top_si = top_si->si_prev;
1352 ccstack = top_si->si_cxstack;
1353 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1356 if (GIMME != G_ARRAY)
1360 if (PL_DBsub && cxix >= 0 &&
1361 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1365 cxix = dopoptosub_at(ccstack, cxix - 1);
1368 cx = &ccstack[cxix];
1369 if (CxTYPE(cx) == CXt_SUB) {
1370 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1371 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1372 field below is defined for any cx. */
1373 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1374 cx = &ccstack[dbcxix];
1377 if (GIMME != G_ARRAY) {
1378 hv = cx->blk_oldcop->cop_stash;
1380 PUSHs(&PL_sv_undef);
1383 sv_setpv(TARG, HvNAME(hv));
1389 hv = cx->blk_oldcop->cop_stash;
1391 PUSHs(&PL_sv_undef);
1393 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1394 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1395 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1398 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1400 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1401 PUSHs(sv_2mortal(sv));
1402 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1405 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1406 PUSHs(sv_2mortal(newSViv(0)));
1408 gimme = (I32)cx->blk_gimme;
1409 if (gimme == G_VOID)
1410 PUSHs(&PL_sv_undef);
1412 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1413 if (CxTYPE(cx) == CXt_EVAL) {
1414 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1415 PUSHs(cx->blk_eval.cur_text);
1418 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1419 /* Require, put the name. */
1420 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1424 else if (CxTYPE(cx) == CXt_SUB &&
1425 cx->blk_sub.hasargs &&
1426 PL_curcop->cop_stash == PL_debstash)
1428 AV *ary = cx->blk_sub.argarray;
1429 int off = AvARRAY(ary) - AvALLOC(ary);
1433 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1436 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1439 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1440 av_extend(PL_dbargs, AvFILLp(ary) + off);
1441 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1442 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1448 sortcv(SV *a, SV *b)
1451 I32 oldsaveix = PL_savestack_ix;
1452 I32 oldscopeix = PL_scopestack_ix;
1454 GvSV(PL_firstgv) = a;
1455 GvSV(PL_secondgv) = b;
1456 PL_stack_sp = PL_stack_base;
1459 if (PL_stack_sp != PL_stack_base + 1)
1460 croak("Sort subroutine didn't return single value");
1461 if (!SvNIOKp(*PL_stack_sp))
1462 croak("Sort subroutine didn't return a numeric value");
1463 result = SvIV(*PL_stack_sp);
1464 while (PL_scopestack_ix > oldscopeix) {
1467 leave_scope(oldsaveix);
1480 sv_reset(tmps, PL_curcop->cop_stash);
1492 PL_curcop = (COP*)PL_op;
1493 TAINT_NOT; /* Each statement is presumed innocent */
1494 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1497 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1501 register PERL_CONTEXT *cx;
1502 I32 gimme = G_ARRAY;
1509 DIE("No DB::DB routine defined");
1511 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1523 push_return(PL_op->op_next);
1524 PUSHBLOCK(cx, CXt_SUB, SP);
1527 (void)SvREFCNT_inc(cv);
1528 SAVESPTR(PL_curpad);
1529 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1530 RETURNOP(CvSTART(cv));
1544 register PERL_CONTEXT *cx;
1545 I32 gimme = GIMME_V;
1552 if (PL_op->op_flags & OPf_SPECIAL)
1553 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1555 #endif /* USE_THREADS */
1556 if (PL_op->op_targ) {
1557 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1562 (void)save_scalar(gv);
1563 svp = &GvSV(gv); /* symbol table variable */
1568 PUSHBLOCK(cx, CXt_LOOP, SP);
1569 PUSHLOOP(cx, svp, MARK);
1570 if (PL_op->op_flags & OPf_STACKED) {
1571 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1572 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1574 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1575 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1576 if (SvNV(sv) < IV_MIN ||
1577 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1578 croak("Range iterator outside integer range");
1579 cx->blk_loop.iterix = SvIV(sv);
1580 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1583 cx->blk_loop.iterlval = newSVsv(sv);
1587 cx->blk_loop.iterary = PL_curstack;
1588 AvFILLp(PL_curstack) = SP - PL_stack_base;
1589 cx->blk_loop.iterix = MARK - PL_stack_base;
1598 register PERL_CONTEXT *cx;
1599 I32 gimme = GIMME_V;
1605 PUSHBLOCK(cx, CXt_LOOP, SP);
1606 PUSHLOOP(cx, 0, SP);
1614 register PERL_CONTEXT *cx;
1615 struct block_loop cxloop;
1623 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1626 if (gimme == G_VOID)
1628 else if (gimme == G_SCALAR) {
1630 *++newsp = sv_mortalcopy(*SP);
1632 *++newsp = &PL_sv_undef;
1636 *++newsp = sv_mortalcopy(*++mark);
1637 TAINT_NOT; /* Each item is independent */
1643 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1644 PL_curpm = newpm; /* ... and pop $1 et al */
1656 register PERL_CONTEXT *cx;
1657 struct block_sub cxsub;
1658 bool popsub2 = FALSE;
1664 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1665 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1666 if (cxstack_ix > PL_sortcxix)
1667 dounwind(PL_sortcxix);
1668 AvARRAY(PL_curstack)[1] = *SP;
1669 PL_stack_sp = PL_stack_base + 1;
1674 cxix = dopoptosub(cxstack_ix);
1676 DIE("Can't return outside a subroutine");
1677 if (cxix < cxstack_ix)
1681 switch (CxTYPE(cx)) {
1683 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1688 if (optype == OP_REQUIRE &&
1689 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1691 /* Unassume the success we assumed earlier. */
1692 char *name = cx->blk_eval.old_name;
1693 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1694 DIE("%s did not return a true value", name);
1698 DIE("panic: return");
1702 if (gimme == G_SCALAR) {
1705 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1707 *++newsp = SvREFCNT_inc(*SP);
1712 *++newsp = sv_mortalcopy(*SP);
1715 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1717 *++newsp = sv_mortalcopy(*SP);
1719 *++newsp = &PL_sv_undef;
1721 else if (gimme == G_ARRAY) {
1722 while (++MARK <= SP) {
1723 *++newsp = (popsub2 && SvTEMP(*MARK))
1724 ? *MARK : sv_mortalcopy(*MARK);
1725 TAINT_NOT; /* Each item is independent */
1728 PL_stack_sp = newsp;
1730 /* Stack values are safe: */
1732 POPSUB2(); /* release CV and @_ ... */
1734 PL_curpm = newpm; /* ... and pop $1 et al */
1737 return pop_return();
1744 register PERL_CONTEXT *cx;
1745 struct block_loop cxloop;
1746 struct block_sub cxsub;
1753 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1755 if (PL_op->op_flags & OPf_SPECIAL) {
1756 cxix = dopoptoloop(cxstack_ix);
1758 DIE("Can't \"last\" outside a block");
1761 cxix = dopoptolabel(cPVOP->op_pv);
1763 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1765 if (cxix < cxstack_ix)
1769 switch (CxTYPE(cx)) {
1771 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1773 nextop = cxloop.last_op->op_next;
1776 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1778 nextop = pop_return();
1782 nextop = pop_return();
1789 if (gimme == G_SCALAR) {
1791 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1792 ? *SP : sv_mortalcopy(*SP);
1794 *++newsp = &PL_sv_undef;
1796 else if (gimme == G_ARRAY) {
1797 while (++MARK <= SP) {
1798 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1799 ? *MARK : sv_mortalcopy(*MARK);
1800 TAINT_NOT; /* Each item is independent */
1806 /* Stack values are safe: */
1809 POPLOOP2(); /* release loop vars ... */
1813 POPSUB2(); /* release CV and @_ ... */
1816 PL_curpm = newpm; /* ... and pop $1 et al */
1825 register PERL_CONTEXT *cx;
1828 if (PL_op->op_flags & OPf_SPECIAL) {
1829 cxix = dopoptoloop(cxstack_ix);
1831 DIE("Can't \"next\" outside a block");
1834 cxix = dopoptolabel(cPVOP->op_pv);
1836 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1838 if (cxix < cxstack_ix)
1842 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1843 LEAVE_SCOPE(oldsave);
1844 return cx->blk_loop.next_op;
1850 register PERL_CONTEXT *cx;
1853 if (PL_op->op_flags & OPf_SPECIAL) {
1854 cxix = dopoptoloop(cxstack_ix);
1856 DIE("Can't \"redo\" outside a block");
1859 cxix = dopoptolabel(cPVOP->op_pv);
1861 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1863 if (cxix < cxstack_ix)
1867 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1868 LEAVE_SCOPE(oldsave);
1869 return cx->blk_loop.redo_op;
1873 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1877 static char too_deep[] = "Target of goto is too deeply nested";
1881 if (o->op_type == OP_LEAVE ||
1882 o->op_type == OP_SCOPE ||
1883 o->op_type == OP_LEAVELOOP ||
1884 o->op_type == OP_LEAVETRY)
1886 *ops++ = cUNOPo->op_first;
1891 if (o->op_flags & OPf_KIDS) {
1893 /* First try all the kids at this level, since that's likeliest. */
1894 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1895 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1896 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1899 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1900 if (kid == PL_lastgotoprobe)
1902 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1904 (ops[-1]->op_type != OP_NEXTSTATE &&
1905 ops[-1]->op_type != OP_DBSTATE)))
1907 if (o = dofindlabel(kid, label, ops, oplimit))
1917 return pp_goto(ARGS);
1926 register PERL_CONTEXT *cx;
1927 #define GOTO_DEPTH 64
1928 OP *enterops[GOTO_DEPTH];
1930 int do_dump = (PL_op->op_type == OP_DUMP);
1933 if (PL_op->op_flags & OPf_STACKED) {
1936 /* This egregious kludge implements goto &subroutine */
1937 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1939 register PERL_CONTEXT *cx;
1940 CV* cv = (CV*)SvRV(sv);
1944 int arg_was_real = 0;
1947 if (!CvROOT(cv) && !CvXSUB(cv)) {
1952 /* autoloaded stub? */
1953 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1955 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1956 GvNAMELEN(gv), FALSE);
1957 if (autogv && (cv = GvCV(autogv)))
1959 tmpstr = sv_newmortal();
1960 gv_efullname3(tmpstr, gv, Nullch);
1961 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1963 DIE("Goto undefined subroutine");
1966 /* First do some returnish stuff. */
1967 cxix = dopoptosub(cxstack_ix);
1969 DIE("Can't goto subroutine outside a subroutine");
1970 if (cxix < cxstack_ix)
1973 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1974 DIE("Can't goto subroutine from an eval-string");
1976 if (CxTYPE(cx) == CXt_SUB &&
1977 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1978 AV* av = cx->blk_sub.argarray;
1980 items = AvFILLp(av) + 1;
1982 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1983 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1984 PL_stack_sp += items;
1986 SvREFCNT_dec(GvAV(PL_defgv));
1987 GvAV(PL_defgv) = cx->blk_sub.savearray;
1988 #endif /* USE_THREADS */
1991 AvREAL_off(av); /* so av_clear() won't clobber elts */
1995 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1999 av = (AV*)PL_curpad[0];
2001 av = GvAV(PL_defgv);
2003 items = AvFILLp(av) + 1;
2005 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2006 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2007 PL_stack_sp += items;
2009 if (CxTYPE(cx) == CXt_SUB &&
2010 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2011 SvREFCNT_dec(cx->blk_sub.cv);
2012 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2013 LEAVE_SCOPE(oldsave);
2015 /* Now do some callish stuff. */
2018 if (CvOLDSTYLE(cv)) {
2019 I32 (*fp3)_((int,int,int));
2024 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2025 items = (*fp3)(CvXSUBANY(cv).any_i32,
2026 mark - PL_stack_base + 1,
2028 SP = PL_stack_base + items;
2034 PL_stack_sp--; /* There is no cv arg. */
2035 /* Push a mark for the start of arglist */
2037 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2038 /* Pop the current context like a decent sub should */
2039 POPBLOCK(cx, PL_curpm);
2040 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2043 return pop_return();
2046 AV* padlist = CvPADLIST(cv);
2047 SV** svp = AvARRAY(padlist);
2048 if (CxTYPE(cx) == CXt_EVAL) {
2049 PL_in_eval = cx->blk_eval.old_in_eval;
2050 PL_eval_root = cx->blk_eval.old_eval_root;
2051 cx->cx_type = CXt_SUB;
2052 cx->blk_sub.hasargs = 0;
2054 cx->blk_sub.cv = cv;
2055 cx->blk_sub.olddepth = CvDEPTH(cv);
2057 if (CvDEPTH(cv) < 2)
2058 (void)SvREFCNT_inc(cv);
2059 else { /* save temporaries on recursion? */
2060 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2061 sub_crush_depth(cv);
2062 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2063 AV *newpad = newAV();
2064 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2065 I32 ix = AvFILLp((AV*)svp[1]);
2066 svp = AvARRAY(svp[0]);
2067 for ( ;ix > 0; ix--) {
2068 if (svp[ix] != &PL_sv_undef) {
2069 char *name = SvPVX(svp[ix]);
2070 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2073 /* outer lexical or anon code */
2074 av_store(newpad, ix,
2075 SvREFCNT_inc(oldpad[ix]) );
2077 else { /* our own lexical */
2079 av_store(newpad, ix, sv = (SV*)newAV());
2080 else if (*name == '%')
2081 av_store(newpad, ix, sv = (SV*)newHV());
2083 av_store(newpad, ix, sv = NEWSV(0,0));
2088 av_store(newpad, ix, sv = NEWSV(0,0));
2092 if (cx->blk_sub.hasargs) {
2095 av_store(newpad, 0, (SV*)av);
2096 AvFLAGS(av) = AVf_REIFY;
2098 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2099 AvFILLp(padlist) = CvDEPTH(cv);
2100 svp = AvARRAY(padlist);
2104 if (!cx->blk_sub.hasargs) {
2105 AV* av = (AV*)PL_curpad[0];
2107 items = AvFILLp(av) + 1;
2109 /* Mark is at the end of the stack. */
2111 Copy(AvARRAY(av), SP + 1, items, SV*);
2116 #endif /* USE_THREADS */
2117 SAVESPTR(PL_curpad);
2118 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2120 if (cx->blk_sub.hasargs)
2121 #endif /* USE_THREADS */
2123 AV* av = (AV*)PL_curpad[0];
2127 cx->blk_sub.savearray = GvAV(PL_defgv);
2128 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2129 #endif /* USE_THREADS */
2130 cx->blk_sub.argarray = av;
2133 if (items >= AvMAX(av) + 1) {
2135 if (AvARRAY(av) != ary) {
2136 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2137 SvPVX(av) = (char*)ary;
2139 if (items >= AvMAX(av) + 1) {
2140 AvMAX(av) = items - 1;
2141 Renew(ary,items+1,SV*);
2143 SvPVX(av) = (char*)ary;
2146 Copy(mark,AvARRAY(av),items,SV*);
2147 AvFILLp(av) = items - 1;
2148 /* preserve @_ nature */
2159 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2161 * We do not care about using sv to call CV;
2162 * it's for informational purposes only.
2164 SV *sv = GvSV(PL_DBsub);
2167 if (PERLDB_SUB_NN) {
2168 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2171 gv_efullname3(sv, CvGV(cv), Nullch);
2174 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2175 PUSHMARK( PL_stack_sp );
2176 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2180 RETURNOP(CvSTART(cv));
2184 label = SvPV(sv,PL_na);
2186 else if (PL_op->op_flags & OPf_SPECIAL) {
2188 DIE("goto must have label");
2191 label = cPVOP->op_pv;
2193 if (label && *label) {
2198 PL_lastgotoprobe = 0;
2200 for (ix = cxstack_ix; ix >= 0; ix--) {
2202 switch (CxTYPE(cx)) {
2204 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2207 gotoprobe = cx->blk_oldcop->op_sibling;
2213 gotoprobe = cx->blk_oldcop->op_sibling;
2215 gotoprobe = PL_main_root;
2218 if (CvDEPTH(cx->blk_sub.cv)) {
2219 gotoprobe = CvROOT(cx->blk_sub.cv);
2224 DIE("Can't \"goto\" outside a block");
2228 gotoprobe = PL_main_root;
2231 retop = dofindlabel(gotoprobe, label,
2232 enterops, enterops + GOTO_DEPTH);
2235 PL_lastgotoprobe = gotoprobe;
2238 DIE("Can't find label %s", label);
2240 /* pop unwanted frames */
2242 if (ix < cxstack_ix) {
2249 oldsave = PL_scopestack[PL_scopestack_ix];
2250 LEAVE_SCOPE(oldsave);
2253 /* push wanted frames */
2255 if (*enterops && enterops[1]) {
2257 for (ix = 1; enterops[ix]; ix++) {
2258 PL_op = enterops[ix];
2259 /* Eventually we may want to stack the needed arguments
2260 * for each op. For now, we punt on the hard ones. */
2261 if (PL_op->op_type == OP_ENTERITER)
2262 DIE("Can't \"goto\" into the middle of a foreach loop",
2264 (CALLOP->op_ppaddr)(ARGS);
2272 if (!retop) retop = PL_main_start;
2274 PL_restartop = retop;
2275 PL_do_undump = TRUE;
2279 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2280 PL_do_undump = FALSE;
2296 if (anum == 1 && VMSISH_EXIT)
2301 PUSHs(&PL_sv_undef);
2309 double value = SvNVx(GvSV(cCOP->cop_gv));
2310 register I32 match = I_32(value);
2313 if (((double)match) > value)
2314 --match; /* was fractional--truncate other way */
2316 match -= cCOP->uop.scop.scop_offset;
2319 else if (match > cCOP->uop.scop.scop_max)
2320 match = cCOP->uop.scop.scop_max;
2321 PL_op = cCOP->uop.scop.scop_next[match];
2331 PL_op = PL_op->op_next; /* can't assume anything */
2333 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2334 match -= cCOP->uop.scop.scop_offset;
2337 else if (match > cCOP->uop.scop.scop_max)
2338 match = cCOP->uop.scop.scop_max;
2339 PL_op = cCOP->uop.scop.scop_next[match];
2348 save_lines(AV *array, SV *sv)
2350 register char *s = SvPVX(sv);
2351 register char *send = SvPVX(sv) + SvCUR(sv);
2353 register I32 line = 1;
2355 while (s && s < send) {
2356 SV *tmpstr = NEWSV(85,0);
2358 sv_upgrade(tmpstr, SVt_PVMG);
2359 t = strchr(s, '\n');
2365 sv_setpvn(tmpstr, s, t - s);
2366 av_store(array, line++, tmpstr);
2381 assert(CATCH_GET == TRUE);
2382 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2386 default: /* topmost level handles it */
2395 PL_op = PL_restartop;
2408 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2409 /* sv Text to convert to OP tree. */
2410 /* startop op_free() this to undo. */
2411 /* code Short string id of the caller. */
2413 dSP; /* Make POPBLOCK work. */
2416 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2419 OP *oop = PL_op, *rop;
2420 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2426 /* switch to eval mode */
2428 if (PL_curcop == &PL_compiling) {
2429 SAVESPTR(PL_compiling.cop_stash);
2430 PL_compiling.cop_stash = PL_curstash;
2432 SAVESPTR(PL_compiling.cop_filegv);
2433 SAVEI16(PL_compiling.cop_line);
2434 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2435 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2436 PL_compiling.cop_line = 1;
2437 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2438 deleting the eval's FILEGV from the stash before gv_check() runs
2439 (i.e. before run-time proper). To work around the coredump that
2440 ensues, we always turn GvMULTI_on for any globals that were
2441 introduced within evals. See force_ident(). GSAR 96-10-12 */
2442 safestr = savepv(tmpbuf);
2443 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2445 #ifdef OP_IN_REGISTER
2453 PL_op->op_type = OP_ENTEREVAL;
2454 PL_op->op_flags = 0; /* Avoid uninit warning. */
2455 PUSHBLOCK(cx, CXt_EVAL, SP);
2456 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2457 rop = doeval(G_SCALAR, startop);
2458 POPBLOCK(cx,PL_curpm);
2461 (*startop)->op_type = OP_NULL;
2462 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2464 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2466 if (PL_curcop == &PL_compiling)
2467 PL_compiling.op_private = PL_hints;
2468 #ifdef OP_IN_REGISTER
2474 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2476 doeval(int gimme, OP** startop)
2489 /* set up a scratch pad */
2492 SAVESPTR(PL_curpad);
2493 SAVESPTR(PL_comppad);
2494 SAVESPTR(PL_comppad_name);
2495 SAVEI32(PL_comppad_name_fill);
2496 SAVEI32(PL_min_intro_pending);
2497 SAVEI32(PL_max_intro_pending);
2500 for (i = cxstack_ix - 1; i >= 0; i--) {
2501 PERL_CONTEXT *cx = &cxstack[i];
2502 if (CxTYPE(cx) == CXt_EVAL)
2504 else if (CxTYPE(cx) == CXt_SUB) {
2505 caller = cx->blk_sub.cv;
2510 SAVESPTR(PL_compcv);
2511 PL_compcv = (CV*)NEWSV(1104,0);
2512 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2513 CvUNIQUE_on(PL_compcv);
2515 CvOWNER(PL_compcv) = 0;
2516 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2517 MUTEX_INIT(CvMUTEXP(PL_compcv));
2518 #endif /* USE_THREADS */
2520 PL_comppad = newAV();
2521 av_push(PL_comppad, Nullsv);
2522 PL_curpad = AvARRAY(PL_comppad);
2523 PL_comppad_name = newAV();
2524 PL_comppad_name_fill = 0;
2525 PL_min_intro_pending = 0;
2528 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2529 PL_curpad[0] = (SV*)newAV();
2530 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2531 #endif /* USE_THREADS */
2533 comppadlist = newAV();
2534 AvREAL_off(comppadlist);
2535 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2536 av_store(comppadlist, 1, (SV*)PL_comppad);
2537 CvPADLIST(PL_compcv) = comppadlist;
2539 if (!saveop || saveop->op_type != OP_REQUIRE)
2540 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2542 SAVEFREESV(PL_compcv);
2544 /* make sure we compile in the right package */
2546 newstash = PL_curcop->cop_stash;
2547 if (PL_curstash != newstash) {
2548 SAVESPTR(PL_curstash);
2549 PL_curstash = newstash;
2551 SAVESPTR(PL_beginav);
2552 PL_beginav = newAV();
2553 SAVEFREESV(PL_beginav);
2555 /* try to compile it */
2557 PL_eval_root = Nullop;
2559 PL_curcop = &PL_compiling;
2560 PL_curcop->cop_arybase = 0;
2561 SvREFCNT_dec(PL_rs);
2562 PL_rs = newSVpv("\n", 1);
2563 if (saveop && saveop->op_flags & OPf_SPECIAL)
2567 if (yyparse() || PL_error_count || !PL_eval_root) {
2571 I32 optype = 0; /* Might be reset by POPEVAL. */
2575 op_free(PL_eval_root);
2576 PL_eval_root = Nullop;
2578 SP = PL_stack_base + POPMARK; /* pop original mark */
2580 POPBLOCK(cx,PL_curpm);
2586 if (optype == OP_REQUIRE) {
2587 char* msg = SvPVx(ERRSV, PL_na);
2588 DIE("%s", *msg ? msg : "Compilation failed in require");
2589 } else if (startop) {
2590 char* msg = SvPVx(ERRSV, PL_na);
2592 POPBLOCK(cx,PL_curpm);
2594 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2596 SvREFCNT_dec(PL_rs);
2597 PL_rs = SvREFCNT_inc(PL_nrs);
2599 MUTEX_LOCK(&PL_eval_mutex);
2601 COND_SIGNAL(&PL_eval_cond);
2602 MUTEX_UNLOCK(&PL_eval_mutex);
2603 #endif /* USE_THREADS */
2606 SvREFCNT_dec(PL_rs);
2607 PL_rs = SvREFCNT_inc(PL_nrs);
2608 PL_compiling.cop_line = 0;
2610 *startop = PL_eval_root;
2611 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2612 CvOUTSIDE(PL_compcv) = Nullcv;
2614 SAVEFREEOP(PL_eval_root);
2616 scalarvoid(PL_eval_root);
2617 else if (gimme & G_ARRAY)
2620 scalar(PL_eval_root);
2622 DEBUG_x(dump_eval());
2624 /* Register with debugger: */
2625 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2626 CV *cv = perl_get_cv("DB::postponed", FALSE);
2630 XPUSHs((SV*)PL_compiling.cop_filegv);
2632 perl_call_sv((SV*)cv, G_DISCARD);
2636 /* compiled okay, so do it */
2638 CvDEPTH(PL_compcv) = 1;
2639 SP = PL_stack_base + POPMARK; /* pop original mark */
2640 PL_op = saveop; /* The caller may need it. */
2642 MUTEX_LOCK(&PL_eval_mutex);
2644 COND_SIGNAL(&PL_eval_cond);
2645 MUTEX_UNLOCK(&PL_eval_mutex);
2646 #endif /* USE_THREADS */
2648 RETURNOP(PL_eval_start);
2654 register PERL_CONTEXT *cx;
2659 SV *namesv = Nullsv;
2661 I32 gimme = G_SCALAR;
2662 PerlIO *tryrsfp = 0;
2665 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2666 SET_NUMERIC_STANDARD();
2667 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2668 DIE("Perl %s required--this is only version %s, stopped",
2669 SvPV(sv,PL_na),PL_patchlevel);
2672 name = SvPV(sv, len);
2673 if (!(name && len > 0 && *name))
2674 DIE("Null filename used");
2675 TAINT_PROPER("require");
2676 if (PL_op->op_type == OP_REQUIRE &&
2677 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2678 *svp != &PL_sv_undef)
2681 /* prepare to compile file */
2686 (name[1] == '.' && name[2] == '/')))
2688 || (name[0] && name[1] == ':')
2691 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2694 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2695 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2700 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2703 AV *ar = GvAVn(PL_incgv);
2707 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2710 namesv = NEWSV(806, 0);
2711 for (i = 0; i <= AvFILL(ar); i++) {
2712 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2715 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2717 sv_setpv(namesv, unixdir);
2718 sv_catpv(namesv, unixname);
2720 sv_setpvf(namesv, "%s/%s", dir, name);
2722 TAINT_PROPER("require");
2723 tryname = SvPVX(namesv);
2724 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2726 if (tryname[0] == '.' && tryname[1] == '/')
2733 SAVESPTR(PL_compiling.cop_filegv);
2734 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2735 SvREFCNT_dec(namesv);
2737 if (PL_op->op_type == OP_REQUIRE) {
2738 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2739 SV *dirmsgsv = NEWSV(0, 0);
2740 AV *ar = GvAVn(PL_incgv);
2742 if (instr(SvPVX(msg), ".h "))
2743 sv_catpv(msg, " (change .h to .ph maybe?)");
2744 if (instr(SvPVX(msg), ".ph "))
2745 sv_catpv(msg, " (did you run h2ph?)");
2746 sv_catpv(msg, " (@INC contains:");
2747 for (i = 0; i <= AvFILL(ar); i++) {
2748 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2749 sv_setpvf(dirmsgsv, " %s", dir);
2750 sv_catsv(msg, dirmsgsv);
2752 sv_catpvn(msg, ")", 1);
2753 SvREFCNT_dec(dirmsgsv);
2760 SETERRNO(0, SS$_NORMAL);
2762 /* Assume success here to prevent recursive requirement. */
2763 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2764 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2768 lex_start(sv_2mortal(newSVpv("",0)));
2769 SAVEGENERICSV(PL_rsfp_filters);
2770 PL_rsfp_filters = Nullav;
2773 name = savepv(name);
2777 SAVEPPTR(PL_compiling.cop_warnings);
2778 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2781 /* switch to eval mode */
2783 push_return(PL_op->op_next);
2784 PUSHBLOCK(cx, CXt_EVAL, SP);
2785 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2787 SAVEI16(PL_compiling.cop_line);
2788 PL_compiling.cop_line = 0;
2792 MUTEX_LOCK(&PL_eval_mutex);
2793 if (PL_eval_owner && PL_eval_owner != thr)
2794 while (PL_eval_owner)
2795 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2796 PL_eval_owner = thr;
2797 MUTEX_UNLOCK(&PL_eval_mutex);
2798 #endif /* USE_THREADS */
2799 return DOCATCH(doeval(G_SCALAR, NULL));
2804 return pp_require(ARGS);
2810 register PERL_CONTEXT *cx;
2812 I32 gimme = GIMME_V, was = PL_sub_generation;
2813 char tmpbuf[TYPE_DIGITS(long) + 12];
2818 if (!SvPV(sv,len) || !len)
2820 TAINT_PROPER("eval");
2826 /* switch to eval mode */
2828 SAVESPTR(PL_compiling.cop_filegv);
2829 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2830 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2831 PL_compiling.cop_line = 1;
2832 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2833 deleting the eval's FILEGV from the stash before gv_check() runs
2834 (i.e. before run-time proper). To work around the coredump that
2835 ensues, we always turn GvMULTI_on for any globals that were
2836 introduced within evals. See force_ident(). GSAR 96-10-12 */
2837 safestr = savepv(tmpbuf);
2838 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2840 PL_hints = PL_op->op_targ;
2841 SAVEPPTR(PL_compiling.cop_warnings);
2842 if (PL_compiling.cop_warnings != WARN_ALL
2843 && PL_compiling.cop_warnings != WARN_NONE){
2844 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2845 SAVEFREESV(PL_compiling.cop_warnings) ;
2848 push_return(PL_op->op_next);
2849 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2850 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2852 /* prepare to compile string */
2854 if (PERLDB_LINE && PL_curstash != PL_debstash)
2855 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2858 MUTEX_LOCK(&PL_eval_mutex);
2859 if (PL_eval_owner && PL_eval_owner != thr)
2860 while (PL_eval_owner)
2861 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2862 PL_eval_owner = thr;
2863 MUTEX_UNLOCK(&PL_eval_mutex);
2864 #endif /* USE_THREADS */
2865 ret = doeval(gimme, NULL);
2866 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2867 && ret != PL_op->op_next) { /* Successive compilation. */
2868 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2870 return DOCATCH(ret);
2880 register PERL_CONTEXT *cx;
2882 U8 save_flags = PL_op -> op_flags;
2887 retop = pop_return();
2890 if (gimme == G_VOID)
2892 else if (gimme == G_SCALAR) {
2895 if (SvFLAGS(TOPs) & SVs_TEMP)
2898 *MARK = sv_mortalcopy(TOPs);
2902 *MARK = &PL_sv_undef;
2906 /* in case LEAVE wipes old return values */
2907 for (mark = newsp + 1; mark <= SP; mark++) {
2908 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2909 *mark = sv_mortalcopy(*mark);
2910 TAINT_NOT; /* Each item is independent */
2914 PL_curpm = newpm; /* Don't pop $1 et al till now */
2917 * Closures mentioned at top level of eval cannot be referenced
2918 * again, and their presence indirectly causes a memory leak.
2919 * (Note that the fact that compcv and friends are still set here
2920 * is, AFAIK, an accident.) --Chip
2922 if (AvFILLp(PL_comppad_name) >= 0) {
2923 SV **svp = AvARRAY(PL_comppad_name);
2925 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2927 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2929 svp[ix] = &PL_sv_undef;
2933 SvREFCNT_dec(CvOUTSIDE(sv));
2934 CvOUTSIDE(sv) = Nullcv;
2947 assert(CvDEPTH(PL_compcv) == 1);
2949 CvDEPTH(PL_compcv) = 0;
2952 if (optype == OP_REQUIRE &&
2953 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2955 /* Unassume the success we assumed earlier. */
2956 char *name = cx->blk_eval.old_name;
2957 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2958 retop = die("%s did not return a true value", name);
2959 /* die_where() did LEAVE, or we won't be here */
2963 if (!(save_flags & OPf_SPECIAL))
2973 register PERL_CONTEXT *cx;
2974 I32 gimme = GIMME_V;
2979 push_return(cLOGOP->op_other->op_next);
2980 PUSHBLOCK(cx, CXt_EVAL, SP);
2982 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2987 return DOCATCH(PL_op->op_next);
2997 register PERL_CONTEXT *cx;
3005 if (gimme == G_VOID)
3007 else if (gimme == G_SCALAR) {
3010 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3013 *MARK = sv_mortalcopy(TOPs);
3017 *MARK = &PL_sv_undef;
3022 /* in case LEAVE wipes old return values */
3023 for (mark = newsp + 1; mark <= SP; mark++) {
3024 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3025 *mark = sv_mortalcopy(*mark);
3026 TAINT_NOT; /* Each item is independent */
3030 PL_curpm = newpm; /* Don't pop $1 et al till now */
3041 register char *s = SvPV_force(sv, len);
3042 register char *send = s + len;
3043 register char *base;
3044 register I32 skipspaces = 0;
3047 bool postspace = FALSE;
3055 croak("Null picture in formline");
3057 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3062 *fpc++ = FF_LINEMARK;
3063 noblank = repeat = FALSE;
3081 case ' ': case '\t':
3092 *fpc++ = FF_LITERAL;
3100 *fpc++ = skipspaces;
3104 *fpc++ = FF_NEWLINE;
3108 arg = fpc - linepc + 1;
3115 *fpc++ = FF_LINEMARK;
3116 noblank = repeat = FALSE;
3125 ischop = s[-1] == '^';
3131 arg = (s - base) - 1;
3133 *fpc++ = FF_LITERAL;
3142 *fpc++ = FF_LINEGLOB;
3144 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3145 arg = ischop ? 512 : 0;
3155 arg |= 256 + (s - f);
3157 *fpc++ = s - base; /* fieldsize for FETCH */
3158 *fpc++ = FF_DECIMAL;
3163 bool ismore = FALSE;
3166 while (*++s == '>') ;
3167 prespace = FF_SPACE;
3169 else if (*s == '|') {
3170 while (*++s == '|') ;
3171 prespace = FF_HALFSPACE;
3176 while (*++s == '<') ;
3179 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3183 *fpc++ = s - base; /* fieldsize for FETCH */
3185 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3203 { /* need to jump to the next word */
3205 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3206 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3207 s = SvPVX(sv) + SvCUR(sv) + z;
3209 Copy(fops, s, arg, U16);
3211 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3216 * The rest of this file was derived from source code contributed
3219 * NOTE: this code was derived from Tom Horsley's qsort replacement
3220 * and should not be confused with the original code.
3223 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3225 Permission granted to distribute under the same terms as perl which are
3228 This program is free software; you can redistribute it and/or modify
3229 it under the terms of either:
3231 a) the GNU General Public License as published by the Free
3232 Software Foundation; either version 1, or (at your option) any
3235 b) the "Artistic License" which comes with this Kit.
3237 Details on the perl license can be found in the perl source code which
3238 may be located via the www.perl.com web page.
3240 This is the most wonderfulest possible qsort I can come up with (and
3241 still be mostly portable) My (limited) tests indicate it consistently
3242 does about 20% fewer calls to compare than does the qsort in the Visual
3243 C++ library, other vendors may vary.
3245 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3246 others I invented myself (or more likely re-invented since they seemed
3247 pretty obvious once I watched the algorithm operate for a while).
3249 Most of this code was written while watching the Marlins sweep the Giants
3250 in the 1997 National League Playoffs - no Braves fans allowed to use this
3251 code (just kidding :-).
3253 I realize that if I wanted to be true to the perl tradition, the only
3254 comment in this file would be something like:
3256 ...they shuffled back towards the rear of the line. 'No, not at the
3257 rear!' the slave-driver shouted. 'Three files up. And stay there...
3259 However, I really needed to violate that tradition just so I could keep
3260 track of what happens myself, not to mention some poor fool trying to
3261 understand this years from now :-).
3264 /* ********************************************************** Configuration */
3266 #ifndef QSORT_ORDER_GUESS
3267 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3270 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3271 future processing - a good max upper bound is log base 2 of memory size
3272 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3273 safely be smaller than that since the program is taking up some space and
3274 most operating systems only let you grab some subset of contiguous
3275 memory (not to mention that you are normally sorting data larger than
3276 1 byte element size :-).
3278 #ifndef QSORT_MAX_STACK
3279 #define QSORT_MAX_STACK 32
3282 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3283 Anything bigger and we use qsort. If you make this too small, the qsort
3284 will probably break (or become less efficient), because it doesn't expect
3285 the middle element of a partition to be the same as the right or left -
3286 you have been warned).
3288 #ifndef QSORT_BREAK_EVEN
3289 #define QSORT_BREAK_EVEN 6
3292 /* ************************************************************* Data Types */
3294 /* hold left and right index values of a partition waiting to be sorted (the
3295 partition includes both left and right - right is NOT one past the end or
3296 anything like that).
3298 struct partition_stack_entry {
3301 #ifdef QSORT_ORDER_GUESS
3302 int qsort_break_even;
3306 /* ******************************************************* Shorthand Macros */
3308 /* Note that these macros will be used from inside the qsort function where
3309 we happen to know that the variable 'elt_size' contains the size of an
3310 array element and the variable 'temp' points to enough space to hold a
3311 temp element and the variable 'array' points to the array being sorted
3312 and 'compare' is the pointer to the compare routine.
3314 Also note that there are very many highly architecture specific ways
3315 these might be sped up, but this is simply the most generally portable
3316 code I could think of.
3319 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3322 #define qsort_cmp(elt1, elt2) \
3323 ((this->*compare)(array[elt1], array[elt2]))
3325 #define qsort_cmp(elt1, elt2) \
3326 ((*compare)(array[elt1], array[elt2]))
3329 #ifdef QSORT_ORDER_GUESS
3330 #define QSORT_NOTICE_SWAP swapped++;
3332 #define QSORT_NOTICE_SWAP
3335 /* swaps contents of array elements elt1, elt2.
3337 #define qsort_swap(elt1, elt2) \
3340 temp = array[elt1]; \
3341 array[elt1] = array[elt2]; \
3342 array[elt2] = temp; \
3345 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3346 elt3 and elt3 gets elt1.
3348 #define qsort_rotate(elt1, elt2, elt3) \
3351 temp = array[elt1]; \
3352 array[elt1] = array[elt2]; \
3353 array[elt2] = array[elt3]; \
3354 array[elt3] = temp; \
3357 /* ************************************************************ Debug stuff */
3364 return; /* good place to set a breakpoint */
3367 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3370 doqsort_all_asserts(
3374 int (*compare)(const void * elt1, const void * elt2),
3375 int pc_left, int pc_right, int u_left, int u_right)
3379 qsort_assert(pc_left <= pc_right);
3380 qsort_assert(u_right < pc_left);
3381 qsort_assert(pc_right < u_left);
3382 for (i = u_right + 1; i < pc_left; ++i) {
3383 qsort_assert(qsort_cmp(i, pc_left) < 0);
3385 for (i = pc_left; i < pc_right; ++i) {
3386 qsort_assert(qsort_cmp(i, pc_right) == 0);
3388 for (i = pc_right + 1; i < u_left; ++i) {
3389 qsort_assert(qsort_cmp(pc_right, i) < 0);
3393 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3394 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3395 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3399 #define qsort_assert(t) ((void)0)
3401 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3405 /* ****************************************************************** qsort */
3409 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3414 I32 (*compare)(SV *a, SV *b))
3419 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3420 int next_stack_entry = 0;
3424 #ifdef QSORT_ORDER_GUESS
3425 int qsort_break_even;
3429 /* Make sure we actually have work to do.
3431 if (num_elts <= 1) {
3435 /* Setup the initial partition definition and fall into the sorting loop
3438 part_right = (int)(num_elts - 1);
3439 #ifdef QSORT_ORDER_GUESS
3440 qsort_break_even = QSORT_BREAK_EVEN;
3442 #define qsort_break_even QSORT_BREAK_EVEN
3445 if ((part_right - part_left) >= qsort_break_even) {
3446 /* OK, this is gonna get hairy, so lets try to document all the
3447 concepts and abbreviations and variables and what they keep
3450 pc: pivot chunk - the set of array elements we accumulate in the
3451 middle of the partition, all equal in value to the original
3452 pivot element selected. The pc is defined by:
3454 pc_left - the leftmost array index of the pc
3455 pc_right - the rightmost array index of the pc
3457 we start with pc_left == pc_right and only one element
3458 in the pivot chunk (but it can grow during the scan).
3460 u: uncompared elements - the set of elements in the partition
3461 we have not yet compared to the pivot value. There are two
3462 uncompared sets during the scan - one to the left of the pc
3463 and one to the right.
3465 u_right - the rightmost index of the left side's uncompared set
3466 u_left - the leftmost index of the right side's uncompared set
3468 The leftmost index of the left sides's uncompared set
3469 doesn't need its own variable because it is always defined
3470 by the leftmost edge of the whole partition (part_left). The
3471 same goes for the rightmost edge of the right partition
3474 We know there are no uncompared elements on the left once we
3475 get u_right < part_left and no uncompared elements on the
3476 right once u_left > part_right. When both these conditions
3477 are met, we have completed the scan of the partition.
3479 Any elements which are between the pivot chunk and the
3480 uncompared elements should be less than the pivot value on
3481 the left side and greater than the pivot value on the right
3482 side (in fact, the goal of the whole algorithm is to arrange
3483 for that to be true and make the groups of less-than and
3484 greater-then elements into new partitions to sort again).
3486 As you marvel at the complexity of the code and wonder why it
3487 has to be so confusing. Consider some of the things this level
3488 of confusion brings:
3490 Once I do a compare, I squeeze every ounce of juice out of it. I
3491 never do compare calls I don't have to do, and I certainly never
3494 I also never swap any elements unless I can prove there is a
3495 good reason. Many sort algorithms will swap a known value with
3496 an uncompared value just to get things in the right place (or
3497 avoid complexity :-), but that uncompared value, once it gets
3498 compared, may then have to be swapped again. A lot of the
3499 complexity of this code is due to the fact that it never swaps
3500 anything except compared values, and it only swaps them when the
3501 compare shows they are out of position.
3503 int pc_left, pc_right;
3504 int u_right, u_left;
3508 pc_left = ((part_left + part_right) / 2);
3510 u_right = pc_left - 1;
3511 u_left = pc_right + 1;
3513 /* Qsort works best when the pivot value is also the median value
3514 in the partition (unfortunately you can't find the median value
3515 without first sorting :-), so to give the algorithm a helping
3516 hand, we pick 3 elements and sort them and use the median value
3517 of that tiny set as the pivot value.
3519 Some versions of qsort like to use the left middle and right as
3520 the 3 elements to sort so they can insure the ends of the
3521 partition will contain values which will stop the scan in the
3522 compare loop, but when you have to call an arbitrarily complex
3523 routine to do a compare, its really better to just keep track of
3524 array index values to know when you hit the edge of the
3525 partition and avoid the extra compare. An even better reason to
3526 avoid using a compare call is the fact that you can drop off the
3527 edge of the array if someone foolishly provides you with an
3528 unstable compare function that doesn't always provide consistent
3531 So, since it is simpler for us to compare the three adjacent
3532 elements in the middle of the partition, those are the ones we
3533 pick here (conveniently pointed at by u_right, pc_left, and
3534 u_left). The values of the left, center, and right elements
3535 are refered to as l c and r in the following comments.
3538 #ifdef QSORT_ORDER_GUESS
3541 s = qsort_cmp(u_right, pc_left);
3544 s = qsort_cmp(pc_left, u_left);
3545 /* if l < c, c < r - already in order - nothing to do */
3547 /* l < c, c == r - already in order, pc grows */
3549 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3551 /* l < c, c > r - need to know more */
3552 s = qsort_cmp(u_right, u_left);
3554 /* l < c, c > r, l < r - swap c & r to get ordered */
3555 qsort_swap(pc_left, u_left);
3556 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3557 } else if (s == 0) {
3558 /* l < c, c > r, l == r - swap c&r, grow pc */
3559 qsort_swap(pc_left, u_left);
3561 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3563 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3564 qsort_rotate(pc_left, u_right, u_left);
3565 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3568 } else if (s == 0) {
3570 s = qsort_cmp(pc_left, u_left);
3572 /* l == c, c < r - already in order, grow pc */
3574 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3575 } else if (s == 0) {
3576 /* l == c, c == r - already in order, grow pc both ways */
3579 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3581 /* l == c, c > r - swap l & r, grow pc */
3582 qsort_swap(u_right, u_left);
3584 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3588 s = qsort_cmp(pc_left, u_left);
3590 /* l > c, c < r - need to know more */
3591 s = qsort_cmp(u_right, u_left);
3593 /* l > c, c < r, l < r - swap l & c to get ordered */
3594 qsort_swap(u_right, pc_left);
3595 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3596 } else if (s == 0) {
3597 /* l > c, c < r, l == r - swap l & c, grow pc */
3598 qsort_swap(u_right, pc_left);
3600 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3602 /* l > c, c < r, l > r - rotate lcr into crl to order */
3603 qsort_rotate(u_right, pc_left, u_left);
3604 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3606 } else if (s == 0) {
3607 /* l > c, c == r - swap ends, grow pc */
3608 qsort_swap(u_right, u_left);
3610 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3612 /* l > c, c > r - swap ends to get in order */
3613 qsort_swap(u_right, u_left);
3614 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3617 /* We now know the 3 middle elements have been compared and
3618 arranged in the desired order, so we can shrink the uncompared
3623 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3625 /* The above massive nested if was the simple part :-). We now have
3626 the middle 3 elements ordered and we need to scan through the
3627 uncompared sets on either side, swapping elements that are on
3628 the wrong side or simply shuffling equal elements around to get
3629 all equal elements into the pivot chunk.
3633 int still_work_on_left;
3634 int still_work_on_right;
3636 /* Scan the uncompared values on the left. If I find a value
3637 equal to the pivot value, move it over so it is adjacent to
3638 the pivot chunk and expand the pivot chunk. If I find a value
3639 less than the pivot value, then just leave it - its already
3640 on the correct side of the partition. If I find a greater
3641 value, then stop the scan.
3643 while (still_work_on_left = (u_right >= part_left)) {
3644 s = qsort_cmp(u_right, pc_left);
3647 } else if (s == 0) {
3649 if (pc_left != u_right) {
3650 qsort_swap(u_right, pc_left);
3656 qsort_assert(u_right < pc_left);
3657 qsort_assert(pc_left <= pc_right);
3658 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3659 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3662 /* Do a mirror image scan of uncompared values on the right
3664 while (still_work_on_right = (u_left <= part_right)) {
3665 s = qsort_cmp(pc_right, u_left);
3668 } else if (s == 0) {
3670 if (pc_right != u_left) {
3671 qsort_swap(pc_right, u_left);
3677 qsort_assert(u_left > pc_right);
3678 qsort_assert(pc_left <= pc_right);
3679 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3680 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3683 if (still_work_on_left) {
3684 /* I know I have a value on the left side which needs to be
3685 on the right side, but I need to know more to decide
3686 exactly the best thing to do with it.
3688 if (still_work_on_right) {
3689 /* I know I have values on both side which are out of
3690 position. This is a big win because I kill two birds
3691 with one swap (so to speak). I can advance the
3692 uncompared pointers on both sides after swapping both
3693 of them into the right place.
3695 qsort_swap(u_right, u_left);
3698 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3700 /* I have an out of position value on the left, but the
3701 right is fully scanned, so I "slide" the pivot chunk
3702 and any less-than values left one to make room for the
3703 greater value over on the right. If the out of position
3704 value is immediately adjacent to the pivot chunk (there
3705 are no less-than values), I can do that with a swap,
3706 otherwise, I have to rotate one of the less than values
3707 into the former position of the out of position value
3708 and the right end of the pivot chunk into the left end
3712 if (pc_left == u_right) {
3713 qsort_swap(u_right, pc_right);
3714 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3716 qsort_rotate(u_right, pc_left, pc_right);
3717 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3722 } else if (still_work_on_right) {
3723 /* Mirror image of complex case above: I have an out of
3724 position value on the right, but the left is fully
3725 scanned, so I need to shuffle things around to make room
3726 for the right value on the left.
3729 if (pc_right == u_left) {
3730 qsort_swap(u_left, pc_left);
3731 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3733 qsort_rotate(pc_right, pc_left, u_left);
3734 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3739 /* No more scanning required on either side of partition,
3740 break out of loop and figure out next set of partitions
3746 /* The elements in the pivot chunk are now in the right place. They
3747 will never move or be compared again. All I have to do is decide
3748 what to do with the stuff to the left and right of the pivot
3751 Notes on the QSORT_ORDER_GUESS ifdef code:
3753 1. If I just built these partitions without swapping any (or
3754 very many) elements, there is a chance that the elements are
3755 already ordered properly (being properly ordered will
3756 certainly result in no swapping, but the converse can't be
3759 2. A (properly written) insertion sort will run faster on
3760 already ordered data than qsort will.
3762 3. Perhaps there is some way to make a good guess about
3763 switching to an insertion sort earlier than partition size 6
3764 (for instance - we could save the partition size on the stack
3765 and increase the size each time we find we didn't swap, thus
3766 switching to insertion sort earlier for partitions with a
3767 history of not swapping).
3769 4. Naturally, if I just switch right away, it will make
3770 artificial benchmarks with pure ascending (or descending)
3771 data look really good, but is that a good reason in general?
3775 #ifdef QSORT_ORDER_GUESS
3777 #if QSORT_ORDER_GUESS == 1
3778 qsort_break_even = (part_right - part_left) + 1;
3780 #if QSORT_ORDER_GUESS == 2
3781 qsort_break_even *= 2;
3783 #if QSORT_ORDER_GUESS == 3
3784 int prev_break = qsort_break_even;
3785 qsort_break_even *= qsort_break_even;
3786 if (qsort_break_even < prev_break) {
3787 qsort_break_even = (part_right - part_left) + 1;
3791 qsort_break_even = QSORT_BREAK_EVEN;
3795 if (part_left < pc_left) {
3796 /* There are elements on the left which need more processing.
3797 Check the right as well before deciding what to do.
3799 if (pc_right < part_right) {
3800 /* We have two partitions to be sorted. Stack the biggest one
3801 and process the smallest one on the next iteration. This
3802 minimizes the stack height by insuring that any additional
3803 stack entries must come from the smallest partition which
3804 (because it is smallest) will have the fewest
3805 opportunities to generate additional stack entries.
3807 if ((part_right - pc_right) > (pc_left - part_left)) {
3808 /* stack the right partition, process the left */
3809 partition_stack[next_stack_entry].left = pc_right + 1;
3810 partition_stack[next_stack_entry].right = part_right;
3811 #ifdef QSORT_ORDER_GUESS
3812 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3814 part_right = pc_left - 1;
3816 /* stack the left partition, process the right */
3817 partition_stack[next_stack_entry].left = part_left;
3818 partition_stack[next_stack_entry].right = pc_left - 1;
3819 #ifdef QSORT_ORDER_GUESS
3820 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3822 part_left = pc_right + 1;
3824 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3827 /* The elements on the left are the only remaining elements
3828 that need sorting, arrange for them to be processed as the
3831 part_right = pc_left - 1;
3833 } else if (pc_right < part_right) {
3834 /* There is only one chunk on the right to be sorted, make it
3835 the new partition and loop back around.
3837 part_left = pc_right + 1;
3839 /* This whole partition wound up in the pivot chunk, so
3840 we need to get a new partition off the stack.
3842 if (next_stack_entry == 0) {
3843 /* the stack is empty - we are done */
3847 part_left = partition_stack[next_stack_entry].left;
3848 part_right = partition_stack[next_stack_entry].right;
3849 #ifdef QSORT_ORDER_GUESS
3850 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3854 /* This partition is too small to fool with qsort complexity, just
3855 do an ordinary insertion sort to minimize overhead.
3858 /* Assume 1st element is in right place already, and start checking
3859 at 2nd element to see where it should be inserted.
3861 for (i = part_left + 1; i <= part_right; ++i) {
3863 /* Scan (backwards - just in case 'i' is already in right place)
3864 through the elements already sorted to see if the ith element
3865 belongs ahead of one of them.
3867 for (j = i - 1; j >= part_left; --j) {
3868 if (qsort_cmp(i, j) >= 0) {
3869 /* i belongs right after j
3876 /* Looks like we really need to move some things
3880 for (k = i - 1; k >= j; --k)
3881 array[k + 1] = array[k];
3886 /* That partition is now sorted, grab the next one, or get out
3887 of the loop if there aren't any more.
3890 if (next_stack_entry == 0) {
3891 /* the stack is empty - we are done */
3895 part_left = partition_stack[next_stack_entry].left;
3896 part_right = partition_stack[next_stack_entry].right;
3897 #ifdef QSORT_ORDER_GUESS
3898 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3903 /* Believe it or not, the array is sorted at this point! */