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);
623 while (*s && isSPACE(*s) && s < send)
627 arg = fieldsize - itemsize;
634 if (strnEQ(s," ",3)) {
635 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
646 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
647 FmLINES(PL_formtarget) += lines;
659 if (PL_stack_base + *PL_markstack_ptr == SP) {
661 if (GIMME_V == G_SCALAR)
663 RETURNOP(PL_op->op_next->op_next);
665 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
666 pp_pushmark(ARGS); /* push dst */
667 pp_pushmark(ARGS); /* push src */
668 ENTER; /* enter outer scope */
672 /* SAVE_DEFSV does *not* suffice here */
673 save_sptr(&THREADSV(0));
675 SAVESPTR(GvSV(PL_defgv));
676 #endif /* USE_THREADS */
677 ENTER; /* enter inner scope */
680 src = PL_stack_base[*PL_markstack_ptr];
685 if (PL_op->op_type == OP_MAPSTART)
686 pp_pushmark(ARGS); /* push top */
687 return ((LOGOP*)PL_op->op_next)->op_other;
692 DIE("panic: mapstart"); /* uses grepstart */
698 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
704 ++PL_markstack_ptr[-1];
706 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
707 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
708 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
713 PL_markstack_ptr[-1] += shift;
714 *PL_markstack_ptr += shift;
718 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
721 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
723 LEAVE; /* exit inner scope */
726 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
730 (void)POPMARK; /* pop top */
731 LEAVE; /* exit outer scope */
732 (void)POPMARK; /* pop src */
733 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
734 (void)POPMARK; /* pop dst */
735 SP = PL_stack_base + POPMARK; /* pop original mark */
736 if (gimme == G_SCALAR) {
740 else if (gimme == G_ARRAY)
747 ENTER; /* enter inner scope */
750 src = PL_stack_base[PL_markstack_ptr[-1]];
754 RETURNOP(cLOGOP->op_other);
758 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
760 if (PL_amagic_generation) { \
761 if (SvAMAGIC(left)||SvAMAGIC(right))\
762 *svp = amagic_call(left, \
770 amagic_cmp(register SV *str1, register SV *str2)
773 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
778 I32 i = SvIVX(tmpsv);
788 return sv_cmp(str1, str2);
792 amagic_cmp_locale(register SV *str1, register SV *str2)
795 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
800 I32 i = SvIVX(tmpsv);
810 return sv_cmp_locale(str1, str2);
815 djSP; dMARK; dORIGMARK;
817 SV **myorigmark = ORIGMARK;
823 OP* nextop = PL_op->op_next;
826 if (gimme != G_ARRAY) {
832 SAVEPPTR(PL_sortcop);
833 if (PL_op->op_flags & OPf_STACKED) {
834 if (PL_op->op_flags & OPf_SPECIAL) {
835 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
836 kid = kUNOP->op_first; /* pass rv2gv */
837 kid = kUNOP->op_first; /* pass leave */
838 PL_sortcop = kid->op_next;
839 stash = PL_curcop->cop_stash;
842 cv = sv_2cv(*++MARK, &stash, &gv, 0);
843 if (!(cv && CvROOT(cv))) {
845 SV *tmpstr = sv_newmortal();
846 gv_efullname3(tmpstr, gv, Nullch);
847 if (cv && CvXSUB(cv))
848 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
849 DIE("Undefined sort subroutine \"%s\" called",
854 DIE("Xsub called in sort");
855 DIE("Undefined subroutine in sort");
857 DIE("Not a CODE reference in sort");
859 PL_sortcop = CvSTART(cv);
860 SAVESPTR(CvROOT(cv)->op_ppaddr);
861 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
864 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
869 stash = PL_curcop->cop_stash;
873 while (MARK < SP) { /* This may or may not shift down one here. */
875 if (*up = *++MARK) { /* Weed out nulls. */
877 if (!PL_sortcop && !SvPOK(*up)) {
881 (void)sv_2pv(*up, &PL_na);
886 max = --up - myorigmark;
891 bool oldcatch = CATCH_GET;
897 PUSHSTACKi(PERLSI_SORT);
898 if (PL_sortstash != stash) {
899 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
900 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
901 PL_sortstash = stash;
904 SAVESPTR(GvSV(PL_firstgv));
905 SAVESPTR(GvSV(PL_secondgv));
907 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
908 if (!(PL_op->op_flags & OPf_SPECIAL)) {
909 bool hasargs = FALSE;
910 cx->cx_type = CXt_SUB;
911 cx->blk_gimme = G_SCALAR;
914 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
916 PL_sortcxix = cxstack_ix;
917 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
919 POPBLOCK(cx,PL_curpm);
927 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
928 qsortsv(ORIGMARK+1, max,
929 (PL_op->op_private & OPpLOCALE)
931 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
932 : FUNC_NAME_TO_PTR(sv_cmp_locale))
934 ? FUNC_NAME_TO_PTR(amagic_cmp)
935 : FUNC_NAME_TO_PTR(sv_cmp) ));
939 PL_stack_sp = ORIGMARK + max;
947 if (GIMME == G_ARRAY)
948 return cCONDOP->op_true;
949 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
956 if (GIMME == G_ARRAY) {
957 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
961 SV *targ = PAD_SV(PL_op->op_targ);
963 if ((PL_op->op_private & OPpFLIP_LINENUM)
964 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
966 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
967 if (PL_op->op_flags & OPf_SPECIAL) {
975 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
988 if (GIMME == G_ARRAY) {
994 if (SvNIOKp(left) || !SvPOKp(left) ||
995 (looks_like_number(left) && *SvPVX(left) != '0') )
997 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
998 croak("Range iterator outside integer range");
1002 EXTEND_MORTAL(max - i + 1);
1003 EXTEND(SP, max - i + 1);
1006 sv = sv_2mortal(newSViv(i++));
1011 SV *final = sv_mortalcopy(right);
1013 char *tmps = SvPV(final, len);
1015 sv = sv_mortalcopy(left);
1016 SvPV_force(sv,PL_na);
1017 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1019 if (strEQ(SvPVX(sv),tmps))
1021 sv = sv_2mortal(newSVsv(sv));
1028 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1030 if ((PL_op->op_private & OPpFLIP_LINENUM)
1031 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1033 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1034 sv_catpv(targ, "E0");
1045 dopoptolabel(char *label)
1049 register PERL_CONTEXT *cx;
1051 for (i = cxstack_ix; i >= 0; i--) {
1053 switch (CxTYPE(cx)) {
1055 if (ckWARN(WARN_UNSAFE))
1056 warner(WARN_UNSAFE, "Exiting substitution via %s",
1057 PL_op_name[PL_op->op_type]);
1060 if (ckWARN(WARN_UNSAFE))
1061 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1062 PL_op_name[PL_op->op_type]);
1065 if (ckWARN(WARN_UNSAFE))
1066 warner(WARN_UNSAFE, "Exiting eval via %s",
1067 PL_op_name[PL_op->op_type]);
1070 if (ckWARN(WARN_UNSAFE))
1071 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1072 PL_op_name[PL_op->op_type]);
1075 if (!cx->blk_loop.label ||
1076 strNE(label, cx->blk_loop.label) ) {
1077 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1078 (long)i, cx->blk_loop.label));
1081 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1091 I32 gimme = block_gimme();
1092 return (gimme == G_VOID) ? G_SCALAR : gimme;
1101 cxix = dopoptosub(cxstack_ix);
1105 switch (cxstack[cxix].blk_gimme) {
1113 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1120 dopoptosub(I32 startingblock)
1123 return dopoptosub_at(cxstack, startingblock);
1127 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1131 register PERL_CONTEXT *cx;
1132 for (i = startingblock; i >= 0; i--) {
1134 switch (CxTYPE(cx)) {
1139 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1147 dopoptoeval(I32 startingblock)
1151 register PERL_CONTEXT *cx;
1152 for (i = startingblock; i >= 0; i--) {
1154 switch (CxTYPE(cx)) {
1158 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1166 dopoptoloop(I32 startingblock)
1170 register PERL_CONTEXT *cx;
1171 for (i = startingblock; i >= 0; i--) {
1173 switch (CxTYPE(cx)) {
1175 if (ckWARN(WARN_UNSAFE))
1176 warner(WARN_UNSAFE, "Exiting substitution via %s",
1177 PL_op_name[PL_op->op_type]);
1180 if (ckWARN(WARN_UNSAFE))
1181 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1182 PL_op_name[PL_op->op_type]);
1185 if (ckWARN(WARN_UNSAFE))
1186 warner(WARN_UNSAFE, "Exiting eval via %s",
1187 PL_op_name[PL_op->op_type]);
1190 if (ckWARN(WARN_UNSAFE))
1191 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1192 PL_op_name[PL_op->op_type]);
1195 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1206 register PERL_CONTEXT *cx;
1210 while (cxstack_ix > cxix) {
1211 cx = &cxstack[cxstack_ix];
1212 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1213 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1214 /* Note: we don't need to restore the base context info till the end. */
1215 switch (CxTYPE(cx)) {
1218 continue; /* not break */
1236 die_where(char *message)
1241 register PERL_CONTEXT *cx;
1246 if (PL_in_eval & 4) {
1248 STRLEN klen = strlen(message);
1250 svp = hv_fetch(ERRHV, message, klen, TRUE);
1253 static char prefix[] = "\t(in cleanup) ";
1255 sv_upgrade(*svp, SVt_IV);
1256 (void)SvIOK_only(*svp);
1259 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1260 sv_catpvn(err, prefix, sizeof(prefix)-1);
1261 sv_catpvn(err, message, klen);
1262 if (ckWARN(WARN_UNSAFE)) {
1263 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1264 warner(WARN_UNSAFE, SvPVX(err)+start);
1271 sv_setpv(ERRSV, message);
1274 message = SvPVx(ERRSV, PL_na);
1276 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1284 if (cxix < cxstack_ix)
1287 POPBLOCK(cx,PL_curpm);
1288 if (CxTYPE(cx) != CXt_EVAL) {
1289 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1294 if (gimme == G_SCALAR)
1295 *++newsp = &PL_sv_undef;
1296 PL_stack_sp = newsp;
1300 if (optype == OP_REQUIRE) {
1301 char* msg = SvPVx(ERRSV, PL_na);
1302 DIE("%s", *msg ? msg : "Compilation failed in require");
1304 return pop_return();
1308 message = SvPVx(ERRSV, PL_na);
1309 PerlIO_printf(PerlIO_stderr(), "%s",message);
1310 PerlIO_flush(PerlIO_stderr());
1319 if (SvTRUE(left) != SvTRUE(right))
1331 RETURNOP(cLOGOP->op_other);
1340 RETURNOP(cLOGOP->op_other);
1346 register I32 cxix = dopoptosub(cxstack_ix);
1347 register PERL_CONTEXT *cx;
1348 register PERL_CONTEXT *ccstack = cxstack;
1349 PERL_SI *top_si = PL_curstackinfo;
1360 /* we may be in a higher stacklevel, so dig down deeper */
1361 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1362 top_si = top_si->si_prev;
1363 ccstack = top_si->si_cxstack;
1364 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1367 if (GIMME != G_ARRAY)
1371 if (PL_DBsub && cxix >= 0 &&
1372 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1376 cxix = dopoptosub_at(ccstack, cxix - 1);
1379 cx = &ccstack[cxix];
1380 if (CxTYPE(cx) == CXt_SUB) {
1381 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1382 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1383 field below is defined for any cx. */
1384 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1385 cx = &ccstack[dbcxix];
1388 if (GIMME != G_ARRAY) {
1389 hv = cx->blk_oldcop->cop_stash;
1391 PUSHs(&PL_sv_undef);
1394 sv_setpv(TARG, HvNAME(hv));
1400 hv = cx->blk_oldcop->cop_stash;
1402 PUSHs(&PL_sv_undef);
1404 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1405 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1406 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1409 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1411 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1412 PUSHs(sv_2mortal(sv));
1413 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1416 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1417 PUSHs(sv_2mortal(newSViv(0)));
1419 gimme = (I32)cx->blk_gimme;
1420 if (gimme == G_VOID)
1421 PUSHs(&PL_sv_undef);
1423 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1424 if (CxTYPE(cx) == CXt_EVAL) {
1425 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1426 PUSHs(cx->blk_eval.cur_text);
1429 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1430 /* Require, put the name. */
1431 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1435 else if (CxTYPE(cx) == CXt_SUB &&
1436 cx->blk_sub.hasargs &&
1437 PL_curcop->cop_stash == PL_debstash)
1439 AV *ary = cx->blk_sub.argarray;
1440 int off = AvARRAY(ary) - AvALLOC(ary);
1444 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1447 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1450 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1451 av_extend(PL_dbargs, AvFILLp(ary) + off);
1452 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1453 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1459 sortcv(SV *a, SV *b)
1462 I32 oldsaveix = PL_savestack_ix;
1463 I32 oldscopeix = PL_scopestack_ix;
1465 GvSV(PL_firstgv) = a;
1466 GvSV(PL_secondgv) = b;
1467 PL_stack_sp = PL_stack_base;
1470 if (PL_stack_sp != PL_stack_base + 1)
1471 croak("Sort subroutine didn't return single value");
1472 if (!SvNIOKp(*PL_stack_sp))
1473 croak("Sort subroutine didn't return a numeric value");
1474 result = SvIV(*PL_stack_sp);
1475 while (PL_scopestack_ix > oldscopeix) {
1478 leave_scope(oldsaveix);
1491 sv_reset(tmps, PL_curcop->cop_stash);
1503 PL_curcop = (COP*)PL_op;
1504 TAINT_NOT; /* Each statement is presumed innocent */
1505 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1508 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1512 register PERL_CONTEXT *cx;
1513 I32 gimme = G_ARRAY;
1520 DIE("No DB::DB routine defined");
1522 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1534 push_return(PL_op->op_next);
1535 PUSHBLOCK(cx, CXt_SUB, SP);
1538 (void)SvREFCNT_inc(cv);
1539 SAVESPTR(PL_curpad);
1540 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1541 RETURNOP(CvSTART(cv));
1555 register PERL_CONTEXT *cx;
1556 I32 gimme = GIMME_V;
1563 if (PL_op->op_flags & OPf_SPECIAL)
1564 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1566 #endif /* USE_THREADS */
1567 if (PL_op->op_targ) {
1568 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1573 (void)save_scalar(gv);
1574 svp = &GvSV(gv); /* symbol table variable */
1579 PUSHBLOCK(cx, CXt_LOOP, SP);
1580 PUSHLOOP(cx, svp, MARK);
1581 if (PL_op->op_flags & OPf_STACKED) {
1582 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1583 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1585 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1586 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1587 if (SvNV(sv) < IV_MIN ||
1588 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1589 croak("Range iterator outside integer range");
1590 cx->blk_loop.iterix = SvIV(sv);
1591 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1594 cx->blk_loop.iterlval = newSVsv(sv);
1598 cx->blk_loop.iterary = PL_curstack;
1599 AvFILLp(PL_curstack) = SP - PL_stack_base;
1600 cx->blk_loop.iterix = MARK - PL_stack_base;
1609 register PERL_CONTEXT *cx;
1610 I32 gimme = GIMME_V;
1616 PUSHBLOCK(cx, CXt_LOOP, SP);
1617 PUSHLOOP(cx, 0, SP);
1625 register PERL_CONTEXT *cx;
1626 struct block_loop cxloop;
1634 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1637 if (gimme == G_VOID)
1639 else if (gimme == G_SCALAR) {
1641 *++newsp = sv_mortalcopy(*SP);
1643 *++newsp = &PL_sv_undef;
1647 *++newsp = sv_mortalcopy(*++mark);
1648 TAINT_NOT; /* Each item is independent */
1654 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1655 PL_curpm = newpm; /* ... and pop $1 et al */
1667 register PERL_CONTEXT *cx;
1668 struct block_sub cxsub;
1669 bool popsub2 = FALSE;
1675 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1676 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1677 if (cxstack_ix > PL_sortcxix)
1678 dounwind(PL_sortcxix);
1679 AvARRAY(PL_curstack)[1] = *SP;
1680 PL_stack_sp = PL_stack_base + 1;
1685 cxix = dopoptosub(cxstack_ix);
1687 DIE("Can't return outside a subroutine");
1688 if (cxix < cxstack_ix)
1692 switch (CxTYPE(cx)) {
1694 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1699 if (optype == OP_REQUIRE &&
1700 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1702 /* Unassume the success we assumed earlier. */
1703 char *name = cx->blk_eval.old_name;
1704 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1705 DIE("%s did not return a true value", name);
1709 DIE("panic: return");
1713 if (gimme == G_SCALAR) {
1716 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1718 *++newsp = SvREFCNT_inc(*SP);
1723 *++newsp = sv_mortalcopy(*SP);
1726 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1728 *++newsp = sv_mortalcopy(*SP);
1730 *++newsp = &PL_sv_undef;
1732 else if (gimme == G_ARRAY) {
1733 while (++MARK <= SP) {
1734 *++newsp = (popsub2 && SvTEMP(*MARK))
1735 ? *MARK : sv_mortalcopy(*MARK);
1736 TAINT_NOT; /* Each item is independent */
1739 PL_stack_sp = newsp;
1741 /* Stack values are safe: */
1743 POPSUB2(); /* release CV and @_ ... */
1745 PL_curpm = newpm; /* ... and pop $1 et al */
1748 return pop_return();
1755 register PERL_CONTEXT *cx;
1756 struct block_loop cxloop;
1757 struct block_sub cxsub;
1764 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1766 if (PL_op->op_flags & OPf_SPECIAL) {
1767 cxix = dopoptoloop(cxstack_ix);
1769 DIE("Can't \"last\" outside a block");
1772 cxix = dopoptolabel(cPVOP->op_pv);
1774 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1776 if (cxix < cxstack_ix)
1780 switch (CxTYPE(cx)) {
1782 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1784 nextop = cxloop.last_op->op_next;
1787 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1789 nextop = pop_return();
1793 nextop = pop_return();
1800 if (gimme == G_SCALAR) {
1802 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1803 ? *SP : sv_mortalcopy(*SP);
1805 *++newsp = &PL_sv_undef;
1807 else if (gimme == G_ARRAY) {
1808 while (++MARK <= SP) {
1809 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1810 ? *MARK : sv_mortalcopy(*MARK);
1811 TAINT_NOT; /* Each item is independent */
1817 /* Stack values are safe: */
1820 POPLOOP2(); /* release loop vars ... */
1824 POPSUB2(); /* release CV and @_ ... */
1827 PL_curpm = newpm; /* ... and pop $1 et al */
1836 register PERL_CONTEXT *cx;
1839 if (PL_op->op_flags & OPf_SPECIAL) {
1840 cxix = dopoptoloop(cxstack_ix);
1842 DIE("Can't \"next\" outside a block");
1845 cxix = dopoptolabel(cPVOP->op_pv);
1847 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1849 if (cxix < cxstack_ix)
1853 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1854 LEAVE_SCOPE(oldsave);
1855 return cx->blk_loop.next_op;
1861 register PERL_CONTEXT *cx;
1864 if (PL_op->op_flags & OPf_SPECIAL) {
1865 cxix = dopoptoloop(cxstack_ix);
1867 DIE("Can't \"redo\" outside a block");
1870 cxix = dopoptolabel(cPVOP->op_pv);
1872 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1874 if (cxix < cxstack_ix)
1878 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1879 LEAVE_SCOPE(oldsave);
1880 return cx->blk_loop.redo_op;
1884 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1888 static char too_deep[] = "Target of goto is too deeply nested";
1892 if (o->op_type == OP_LEAVE ||
1893 o->op_type == OP_SCOPE ||
1894 o->op_type == OP_LEAVELOOP ||
1895 o->op_type == OP_LEAVETRY)
1897 *ops++ = cUNOPo->op_first;
1902 if (o->op_flags & OPf_KIDS) {
1904 /* First try all the kids at this level, since that's likeliest. */
1905 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1906 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1907 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1910 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1911 if (kid == PL_lastgotoprobe)
1913 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1915 (ops[-1]->op_type != OP_NEXTSTATE &&
1916 ops[-1]->op_type != OP_DBSTATE)))
1918 if (o = dofindlabel(kid, label, ops, oplimit))
1928 return pp_goto(ARGS);
1937 register PERL_CONTEXT *cx;
1938 #define GOTO_DEPTH 64
1939 OP *enterops[GOTO_DEPTH];
1941 int do_dump = (PL_op->op_type == OP_DUMP);
1944 if (PL_op->op_flags & OPf_STACKED) {
1947 /* This egregious kludge implements goto &subroutine */
1948 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1950 register PERL_CONTEXT *cx;
1951 CV* cv = (CV*)SvRV(sv);
1955 int arg_was_real = 0;
1958 if (!CvROOT(cv) && !CvXSUB(cv)) {
1963 /* autoloaded stub? */
1964 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1966 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1967 GvNAMELEN(gv), FALSE);
1968 if (autogv && (cv = GvCV(autogv)))
1970 tmpstr = sv_newmortal();
1971 gv_efullname3(tmpstr, gv, Nullch);
1972 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1974 DIE("Goto undefined subroutine");
1977 /* First do some returnish stuff. */
1978 cxix = dopoptosub(cxstack_ix);
1980 DIE("Can't goto subroutine outside a subroutine");
1981 if (cxix < cxstack_ix)
1984 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1985 DIE("Can't goto subroutine from an eval-string");
1987 if (CxTYPE(cx) == CXt_SUB &&
1988 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1989 AV* av = cx->blk_sub.argarray;
1991 items = AvFILLp(av) + 1;
1993 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1994 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1995 PL_stack_sp += items;
1997 SvREFCNT_dec(GvAV(PL_defgv));
1998 GvAV(PL_defgv) = cx->blk_sub.savearray;
1999 #endif /* USE_THREADS */
2002 AvREAL_off(av); /* so av_clear() won't clobber elts */
2006 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2010 av = (AV*)PL_curpad[0];
2012 av = GvAV(PL_defgv);
2014 items = AvFILLp(av) + 1;
2016 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2017 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2018 PL_stack_sp += items;
2020 if (CxTYPE(cx) == CXt_SUB &&
2021 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2022 SvREFCNT_dec(cx->blk_sub.cv);
2023 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2024 LEAVE_SCOPE(oldsave);
2026 /* Now do some callish stuff. */
2029 if (CvOLDSTYLE(cv)) {
2030 I32 (*fp3)_((int,int,int));
2035 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2036 items = (*fp3)(CvXSUBANY(cv).any_i32,
2037 mark - PL_stack_base + 1,
2039 SP = PL_stack_base + items;
2045 PL_stack_sp--; /* There is no cv arg. */
2046 /* Push a mark for the start of arglist */
2048 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2049 /* Pop the current context like a decent sub should */
2050 POPBLOCK(cx, PL_curpm);
2051 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2054 return pop_return();
2057 AV* padlist = CvPADLIST(cv);
2058 SV** svp = AvARRAY(padlist);
2059 if (CxTYPE(cx) == CXt_EVAL) {
2060 PL_in_eval = cx->blk_eval.old_in_eval;
2061 PL_eval_root = cx->blk_eval.old_eval_root;
2062 cx->cx_type = CXt_SUB;
2063 cx->blk_sub.hasargs = 0;
2065 cx->blk_sub.cv = cv;
2066 cx->blk_sub.olddepth = CvDEPTH(cv);
2068 if (CvDEPTH(cv) < 2)
2069 (void)SvREFCNT_inc(cv);
2070 else { /* save temporaries on recursion? */
2071 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2072 sub_crush_depth(cv);
2073 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2074 AV *newpad = newAV();
2075 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2076 I32 ix = AvFILLp((AV*)svp[1]);
2077 svp = AvARRAY(svp[0]);
2078 for ( ;ix > 0; ix--) {
2079 if (svp[ix] != &PL_sv_undef) {
2080 char *name = SvPVX(svp[ix]);
2081 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2084 /* outer lexical or anon code */
2085 av_store(newpad, ix,
2086 SvREFCNT_inc(oldpad[ix]) );
2088 else { /* our own lexical */
2090 av_store(newpad, ix, sv = (SV*)newAV());
2091 else if (*name == '%')
2092 av_store(newpad, ix, sv = (SV*)newHV());
2094 av_store(newpad, ix, sv = NEWSV(0,0));
2099 av_store(newpad, ix, sv = NEWSV(0,0));
2103 if (cx->blk_sub.hasargs) {
2106 av_store(newpad, 0, (SV*)av);
2107 AvFLAGS(av) = AVf_REIFY;
2109 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2110 AvFILLp(padlist) = CvDEPTH(cv);
2111 svp = AvARRAY(padlist);
2115 if (!cx->blk_sub.hasargs) {
2116 AV* av = (AV*)PL_curpad[0];
2118 items = AvFILLp(av) + 1;
2120 /* Mark is at the end of the stack. */
2122 Copy(AvARRAY(av), SP + 1, items, SV*);
2127 #endif /* USE_THREADS */
2128 SAVESPTR(PL_curpad);
2129 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2131 if (cx->blk_sub.hasargs)
2132 #endif /* USE_THREADS */
2134 AV* av = (AV*)PL_curpad[0];
2138 cx->blk_sub.savearray = GvAV(PL_defgv);
2139 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2140 #endif /* USE_THREADS */
2141 cx->blk_sub.argarray = av;
2144 if (items >= AvMAX(av) + 1) {
2146 if (AvARRAY(av) != ary) {
2147 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2148 SvPVX(av) = (char*)ary;
2150 if (items >= AvMAX(av) + 1) {
2151 AvMAX(av) = items - 1;
2152 Renew(ary,items+1,SV*);
2154 SvPVX(av) = (char*)ary;
2157 Copy(mark,AvARRAY(av),items,SV*);
2158 AvFILLp(av) = items - 1;
2159 /* preserve @_ nature */
2170 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2172 * We do not care about using sv to call CV;
2173 * it's for informational purposes only.
2175 SV *sv = GvSV(PL_DBsub);
2178 if (PERLDB_SUB_NN) {
2179 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2182 gv_efullname3(sv, CvGV(cv), Nullch);
2185 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2186 PUSHMARK( PL_stack_sp );
2187 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2191 RETURNOP(CvSTART(cv));
2195 label = SvPV(sv,PL_na);
2197 else if (PL_op->op_flags & OPf_SPECIAL) {
2199 DIE("goto must have label");
2202 label = cPVOP->op_pv;
2204 if (label && *label) {
2209 PL_lastgotoprobe = 0;
2211 for (ix = cxstack_ix; ix >= 0; ix--) {
2213 switch (CxTYPE(cx)) {
2215 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2218 gotoprobe = cx->blk_oldcop->op_sibling;
2224 gotoprobe = cx->blk_oldcop->op_sibling;
2226 gotoprobe = PL_main_root;
2229 if (CvDEPTH(cx->blk_sub.cv)) {
2230 gotoprobe = CvROOT(cx->blk_sub.cv);
2235 DIE("Can't \"goto\" outside a block");
2239 gotoprobe = PL_main_root;
2242 retop = dofindlabel(gotoprobe, label,
2243 enterops, enterops + GOTO_DEPTH);
2246 PL_lastgotoprobe = gotoprobe;
2249 DIE("Can't find label %s", label);
2251 /* pop unwanted frames */
2253 if (ix < cxstack_ix) {
2260 oldsave = PL_scopestack[PL_scopestack_ix];
2261 LEAVE_SCOPE(oldsave);
2264 /* push wanted frames */
2266 if (*enterops && enterops[1]) {
2268 for (ix = 1; enterops[ix]; ix++) {
2269 PL_op = enterops[ix];
2270 /* Eventually we may want to stack the needed arguments
2271 * for each op. For now, we punt on the hard ones. */
2272 if (PL_op->op_type == OP_ENTERITER)
2273 DIE("Can't \"goto\" into the middle of a foreach loop",
2275 (CALLOP->op_ppaddr)(ARGS);
2283 if (!retop) retop = PL_main_start;
2285 PL_restartop = retop;
2286 PL_do_undump = TRUE;
2290 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2291 PL_do_undump = FALSE;
2307 if (anum == 1 && VMSISH_EXIT)
2312 PUSHs(&PL_sv_undef);
2320 double value = SvNVx(GvSV(cCOP->cop_gv));
2321 register I32 match = I_32(value);
2324 if (((double)match) > value)
2325 --match; /* was fractional--truncate other way */
2327 match -= cCOP->uop.scop.scop_offset;
2330 else if (match > cCOP->uop.scop.scop_max)
2331 match = cCOP->uop.scop.scop_max;
2332 PL_op = cCOP->uop.scop.scop_next[match];
2342 PL_op = PL_op->op_next; /* can't assume anything */
2344 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2345 match -= cCOP->uop.scop.scop_offset;
2348 else if (match > cCOP->uop.scop.scop_max)
2349 match = cCOP->uop.scop.scop_max;
2350 PL_op = cCOP->uop.scop.scop_next[match];
2359 save_lines(AV *array, SV *sv)
2361 register char *s = SvPVX(sv);
2362 register char *send = SvPVX(sv) + SvCUR(sv);
2364 register I32 line = 1;
2366 while (s && s < send) {
2367 SV *tmpstr = NEWSV(85,0);
2369 sv_upgrade(tmpstr, SVt_PVMG);
2370 t = strchr(s, '\n');
2376 sv_setpvn(tmpstr, s, t - s);
2377 av_store(array, line++, tmpstr);
2392 assert(CATCH_GET == TRUE);
2393 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2397 default: /* topmost level handles it */
2406 PL_op = PL_restartop;
2419 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2420 /* sv Text to convert to OP tree. */
2421 /* startop op_free() this to undo. */
2422 /* code Short string id of the caller. */
2424 dSP; /* Make POPBLOCK work. */
2427 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2430 OP *oop = PL_op, *rop;
2431 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2437 /* switch to eval mode */
2439 if (PL_curcop == &PL_compiling) {
2440 SAVESPTR(PL_compiling.cop_stash);
2441 PL_compiling.cop_stash = PL_curstash;
2443 SAVESPTR(PL_compiling.cop_filegv);
2444 SAVEI16(PL_compiling.cop_line);
2445 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2446 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2447 PL_compiling.cop_line = 1;
2448 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2449 deleting the eval's FILEGV from the stash before gv_check() runs
2450 (i.e. before run-time proper). To work around the coredump that
2451 ensues, we always turn GvMULTI_on for any globals that were
2452 introduced within evals. See force_ident(). GSAR 96-10-12 */
2453 safestr = savepv(tmpbuf);
2454 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2456 #ifdef OP_IN_REGISTER
2464 PL_op->op_type = OP_ENTEREVAL;
2465 PL_op->op_flags = 0; /* Avoid uninit warning. */
2466 PUSHBLOCK(cx, CXt_EVAL, SP);
2467 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2468 rop = doeval(G_SCALAR, startop);
2469 POPBLOCK(cx,PL_curpm);
2472 (*startop)->op_type = OP_NULL;
2473 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2475 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2477 if (PL_curcop == &PL_compiling)
2478 PL_compiling.op_private = PL_hints;
2479 #ifdef OP_IN_REGISTER
2485 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2487 doeval(int gimme, OP** startop)
2500 /* set up a scratch pad */
2503 SAVESPTR(PL_curpad);
2504 SAVESPTR(PL_comppad);
2505 SAVESPTR(PL_comppad_name);
2506 SAVEI32(PL_comppad_name_fill);
2507 SAVEI32(PL_min_intro_pending);
2508 SAVEI32(PL_max_intro_pending);
2511 for (i = cxstack_ix - 1; i >= 0; i--) {
2512 PERL_CONTEXT *cx = &cxstack[i];
2513 if (CxTYPE(cx) == CXt_EVAL)
2515 else if (CxTYPE(cx) == CXt_SUB) {
2516 caller = cx->blk_sub.cv;
2521 SAVESPTR(PL_compcv);
2522 PL_compcv = (CV*)NEWSV(1104,0);
2523 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2524 CvUNIQUE_on(PL_compcv);
2526 CvOWNER(PL_compcv) = 0;
2527 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2528 MUTEX_INIT(CvMUTEXP(PL_compcv));
2529 #endif /* USE_THREADS */
2531 PL_comppad = newAV();
2532 av_push(PL_comppad, Nullsv);
2533 PL_curpad = AvARRAY(PL_comppad);
2534 PL_comppad_name = newAV();
2535 PL_comppad_name_fill = 0;
2536 PL_min_intro_pending = 0;
2539 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2540 PL_curpad[0] = (SV*)newAV();
2541 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2542 #endif /* USE_THREADS */
2544 comppadlist = newAV();
2545 AvREAL_off(comppadlist);
2546 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2547 av_store(comppadlist, 1, (SV*)PL_comppad);
2548 CvPADLIST(PL_compcv) = comppadlist;
2550 if (!saveop || saveop->op_type != OP_REQUIRE)
2551 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2553 SAVEFREESV(PL_compcv);
2555 /* make sure we compile in the right package */
2557 newstash = PL_curcop->cop_stash;
2558 if (PL_curstash != newstash) {
2559 SAVESPTR(PL_curstash);
2560 PL_curstash = newstash;
2562 SAVESPTR(PL_beginav);
2563 PL_beginav = newAV();
2564 SAVEFREESV(PL_beginav);
2566 /* try to compile it */
2568 PL_eval_root = Nullop;
2570 PL_curcop = &PL_compiling;
2571 PL_curcop->cop_arybase = 0;
2572 SvREFCNT_dec(PL_rs);
2573 PL_rs = newSVpv("\n", 1);
2574 if (saveop && saveop->op_flags & OPf_SPECIAL)
2578 if (yyparse() || PL_error_count || !PL_eval_root) {
2582 I32 optype = 0; /* Might be reset by POPEVAL. */
2586 op_free(PL_eval_root);
2587 PL_eval_root = Nullop;
2589 SP = PL_stack_base + POPMARK; /* pop original mark */
2591 POPBLOCK(cx,PL_curpm);
2597 if (optype == OP_REQUIRE) {
2598 char* msg = SvPVx(ERRSV, PL_na);
2599 DIE("%s", *msg ? msg : "Compilation failed in require");
2600 } else if (startop) {
2601 char* msg = SvPVx(ERRSV, PL_na);
2603 POPBLOCK(cx,PL_curpm);
2605 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2607 SvREFCNT_dec(PL_rs);
2608 PL_rs = SvREFCNT_inc(PL_nrs);
2610 MUTEX_LOCK(&PL_eval_mutex);
2612 COND_SIGNAL(&PL_eval_cond);
2613 MUTEX_UNLOCK(&PL_eval_mutex);
2614 #endif /* USE_THREADS */
2617 SvREFCNT_dec(PL_rs);
2618 PL_rs = SvREFCNT_inc(PL_nrs);
2619 PL_compiling.cop_line = 0;
2621 *startop = PL_eval_root;
2622 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2623 CvOUTSIDE(PL_compcv) = Nullcv;
2625 SAVEFREEOP(PL_eval_root);
2627 scalarvoid(PL_eval_root);
2628 else if (gimme & G_ARRAY)
2631 scalar(PL_eval_root);
2633 DEBUG_x(dump_eval());
2635 /* Register with debugger: */
2636 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2637 CV *cv = perl_get_cv("DB::postponed", FALSE);
2641 XPUSHs((SV*)PL_compiling.cop_filegv);
2643 perl_call_sv((SV*)cv, G_DISCARD);
2647 /* compiled okay, so do it */
2649 CvDEPTH(PL_compcv) = 1;
2650 SP = PL_stack_base + POPMARK; /* pop original mark */
2651 PL_op = saveop; /* The caller may need it. */
2653 MUTEX_LOCK(&PL_eval_mutex);
2655 COND_SIGNAL(&PL_eval_cond);
2656 MUTEX_UNLOCK(&PL_eval_mutex);
2657 #endif /* USE_THREADS */
2659 RETURNOP(PL_eval_start);
2665 register PERL_CONTEXT *cx;
2670 SV *namesv = Nullsv;
2672 I32 gimme = G_SCALAR;
2673 PerlIO *tryrsfp = 0;
2676 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2677 SET_NUMERIC_STANDARD();
2678 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2679 DIE("Perl %s required--this is only version %s, stopped",
2680 SvPV(sv,PL_na),PL_patchlevel);
2683 name = SvPV(sv, len);
2684 if (!(name && len > 0 && *name))
2685 DIE("Null filename used");
2686 TAINT_PROPER("require");
2687 if (PL_op->op_type == OP_REQUIRE &&
2688 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2689 *svp != &PL_sv_undef)
2692 /* prepare to compile file */
2697 (name[1] == '.' && name[2] == '/')))
2699 || (name[0] && name[1] == ':')
2702 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2705 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2706 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2711 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2714 AV *ar = GvAVn(PL_incgv);
2718 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2721 namesv = NEWSV(806, 0);
2722 for (i = 0; i <= AvFILL(ar); i++) {
2723 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2726 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2728 sv_setpv(namesv, unixdir);
2729 sv_catpv(namesv, unixname);
2731 sv_setpvf(namesv, "%s/%s", dir, name);
2733 TAINT_PROPER("require");
2734 tryname = SvPVX(namesv);
2735 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2737 if (tryname[0] == '.' && tryname[1] == '/')
2744 SAVESPTR(PL_compiling.cop_filegv);
2745 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2746 SvREFCNT_dec(namesv);
2748 if (PL_op->op_type == OP_REQUIRE) {
2749 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2750 SV *dirmsgsv = NEWSV(0, 0);
2751 AV *ar = GvAVn(PL_incgv);
2753 if (instr(SvPVX(msg), ".h "))
2754 sv_catpv(msg, " (change .h to .ph maybe?)");
2755 if (instr(SvPVX(msg), ".ph "))
2756 sv_catpv(msg, " (did you run h2ph?)");
2757 sv_catpv(msg, " (@INC contains:");
2758 for (i = 0; i <= AvFILL(ar); i++) {
2759 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2760 sv_setpvf(dirmsgsv, " %s", dir);
2761 sv_catsv(msg, dirmsgsv);
2763 sv_catpvn(msg, ")", 1);
2764 SvREFCNT_dec(dirmsgsv);
2771 SETERRNO(0, SS$_NORMAL);
2773 /* Assume success here to prevent recursive requirement. */
2774 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2775 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2779 lex_start(sv_2mortal(newSVpv("",0)));
2780 SAVEGENERICSV(PL_rsfp_filters);
2781 PL_rsfp_filters = Nullav;
2784 name = savepv(name);
2788 SAVEPPTR(PL_compiling.cop_warnings);
2789 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2792 /* switch to eval mode */
2794 push_return(PL_op->op_next);
2795 PUSHBLOCK(cx, CXt_EVAL, SP);
2796 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2798 SAVEI16(PL_compiling.cop_line);
2799 PL_compiling.cop_line = 0;
2803 MUTEX_LOCK(&PL_eval_mutex);
2804 if (PL_eval_owner && PL_eval_owner != thr)
2805 while (PL_eval_owner)
2806 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2807 PL_eval_owner = thr;
2808 MUTEX_UNLOCK(&PL_eval_mutex);
2809 #endif /* USE_THREADS */
2810 return DOCATCH(doeval(G_SCALAR, NULL));
2815 return pp_require(ARGS);
2821 register PERL_CONTEXT *cx;
2823 I32 gimme = GIMME_V, was = PL_sub_generation;
2824 char tmpbuf[TYPE_DIGITS(long) + 12];
2829 if (!SvPV(sv,len) || !len)
2831 TAINT_PROPER("eval");
2837 /* switch to eval mode */
2839 SAVESPTR(PL_compiling.cop_filegv);
2840 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2841 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2842 PL_compiling.cop_line = 1;
2843 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2844 deleting the eval's FILEGV from the stash before gv_check() runs
2845 (i.e. before run-time proper). To work around the coredump that
2846 ensues, we always turn GvMULTI_on for any globals that were
2847 introduced within evals. See force_ident(). GSAR 96-10-12 */
2848 safestr = savepv(tmpbuf);
2849 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2851 PL_hints = PL_op->op_targ;
2852 SAVEPPTR(PL_compiling.cop_warnings);
2853 if (PL_compiling.cop_warnings != WARN_ALL
2854 && PL_compiling.cop_warnings != WARN_NONE){
2855 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2856 SAVEFREESV(PL_compiling.cop_warnings) ;
2859 push_return(PL_op->op_next);
2860 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2861 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2863 /* prepare to compile string */
2865 if (PERLDB_LINE && PL_curstash != PL_debstash)
2866 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2869 MUTEX_LOCK(&PL_eval_mutex);
2870 if (PL_eval_owner && PL_eval_owner != thr)
2871 while (PL_eval_owner)
2872 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2873 PL_eval_owner = thr;
2874 MUTEX_UNLOCK(&PL_eval_mutex);
2875 #endif /* USE_THREADS */
2876 ret = doeval(gimme, NULL);
2877 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2878 && ret != PL_op->op_next) { /* Successive compilation. */
2879 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2881 return DOCATCH(ret);
2891 register PERL_CONTEXT *cx;
2893 U8 save_flags = PL_op -> op_flags;
2898 retop = pop_return();
2901 if (gimme == G_VOID)
2903 else if (gimme == G_SCALAR) {
2906 if (SvFLAGS(TOPs) & SVs_TEMP)
2909 *MARK = sv_mortalcopy(TOPs);
2913 *MARK = &PL_sv_undef;
2917 /* in case LEAVE wipes old return values */
2918 for (mark = newsp + 1; mark <= SP; mark++) {
2919 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2920 *mark = sv_mortalcopy(*mark);
2921 TAINT_NOT; /* Each item is independent */
2925 PL_curpm = newpm; /* Don't pop $1 et al till now */
2928 * Closures mentioned at top level of eval cannot be referenced
2929 * again, and their presence indirectly causes a memory leak.
2930 * (Note that the fact that compcv and friends are still set here
2931 * is, AFAIK, an accident.) --Chip
2933 if (AvFILLp(PL_comppad_name) >= 0) {
2934 SV **svp = AvARRAY(PL_comppad_name);
2936 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2938 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2940 svp[ix] = &PL_sv_undef;
2944 SvREFCNT_dec(CvOUTSIDE(sv));
2945 CvOUTSIDE(sv) = Nullcv;
2958 assert(CvDEPTH(PL_compcv) == 1);
2960 CvDEPTH(PL_compcv) = 0;
2963 if (optype == OP_REQUIRE &&
2964 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2966 /* Unassume the success we assumed earlier. */
2967 char *name = cx->blk_eval.old_name;
2968 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2969 retop = die("%s did not return a true value", name);
2970 /* die_where() did LEAVE, or we won't be here */
2974 if (!(save_flags & OPf_SPECIAL))
2984 register PERL_CONTEXT *cx;
2985 I32 gimme = GIMME_V;
2990 push_return(cLOGOP->op_other->op_next);
2991 PUSHBLOCK(cx, CXt_EVAL, SP);
2993 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2998 return DOCATCH(PL_op->op_next);
3008 register PERL_CONTEXT *cx;
3016 if (gimme == G_VOID)
3018 else if (gimme == G_SCALAR) {
3021 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3024 *MARK = sv_mortalcopy(TOPs);
3028 *MARK = &PL_sv_undef;
3033 /* in case LEAVE wipes old return values */
3034 for (mark = newsp + 1; mark <= SP; mark++) {
3035 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3036 *mark = sv_mortalcopy(*mark);
3037 TAINT_NOT; /* Each item is independent */
3041 PL_curpm = newpm; /* Don't pop $1 et al till now */
3052 register char *s = SvPV_force(sv, len);
3053 register char *send = s + len;
3054 register char *base;
3055 register I32 skipspaces = 0;
3058 bool postspace = FALSE;
3066 croak("Null picture in formline");
3068 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3073 *fpc++ = FF_LINEMARK;
3074 noblank = repeat = FALSE;
3092 case ' ': case '\t':
3103 *fpc++ = FF_LITERAL;
3111 *fpc++ = skipspaces;
3115 *fpc++ = FF_NEWLINE;
3119 arg = fpc - linepc + 1;
3126 *fpc++ = FF_LINEMARK;
3127 noblank = repeat = FALSE;
3136 ischop = s[-1] == '^';
3142 arg = (s - base) - 1;
3144 *fpc++ = FF_LITERAL;
3153 *fpc++ = FF_LINEGLOB;
3155 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3156 arg = ischop ? 512 : 0;
3166 arg |= 256 + (s - f);
3168 *fpc++ = s - base; /* fieldsize for FETCH */
3169 *fpc++ = FF_DECIMAL;
3174 bool ismore = FALSE;
3177 while (*++s == '>') ;
3178 prespace = FF_SPACE;
3180 else if (*s == '|') {
3181 while (*++s == '|') ;
3182 prespace = FF_HALFSPACE;
3187 while (*++s == '<') ;
3190 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3194 *fpc++ = s - base; /* fieldsize for FETCH */
3196 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3214 { /* need to jump to the next word */
3216 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3217 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3218 s = SvPVX(sv) + SvCUR(sv) + z;
3220 Copy(fops, s, arg, U16);
3222 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3227 * The rest of this file was derived from source code contributed
3230 * NOTE: this code was derived from Tom Horsley's qsort replacement
3231 * and should not be confused with the original code.
3234 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3236 Permission granted to distribute under the same terms as perl which are
3239 This program is free software; you can redistribute it and/or modify
3240 it under the terms of either:
3242 a) the GNU General Public License as published by the Free
3243 Software Foundation; either version 1, or (at your option) any
3246 b) the "Artistic License" which comes with this Kit.
3248 Details on the perl license can be found in the perl source code which
3249 may be located via the www.perl.com web page.
3251 This is the most wonderfulest possible qsort I can come up with (and
3252 still be mostly portable) My (limited) tests indicate it consistently
3253 does about 20% fewer calls to compare than does the qsort in the Visual
3254 C++ library, other vendors may vary.
3256 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3257 others I invented myself (or more likely re-invented since they seemed
3258 pretty obvious once I watched the algorithm operate for a while).
3260 Most of this code was written while watching the Marlins sweep the Giants
3261 in the 1997 National League Playoffs - no Braves fans allowed to use this
3262 code (just kidding :-).
3264 I realize that if I wanted to be true to the perl tradition, the only
3265 comment in this file would be something like:
3267 ...they shuffled back towards the rear of the line. 'No, not at the
3268 rear!' the slave-driver shouted. 'Three files up. And stay there...
3270 However, I really needed to violate that tradition just so I could keep
3271 track of what happens myself, not to mention some poor fool trying to
3272 understand this years from now :-).
3275 /* ********************************************************** Configuration */
3277 #ifndef QSORT_ORDER_GUESS
3278 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3281 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3282 future processing - a good max upper bound is log base 2 of memory size
3283 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3284 safely be smaller than that since the program is taking up some space and
3285 most operating systems only let you grab some subset of contiguous
3286 memory (not to mention that you are normally sorting data larger than
3287 1 byte element size :-).
3289 #ifndef QSORT_MAX_STACK
3290 #define QSORT_MAX_STACK 32
3293 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3294 Anything bigger and we use qsort. If you make this too small, the qsort
3295 will probably break (or become less efficient), because it doesn't expect
3296 the middle element of a partition to be the same as the right or left -
3297 you have been warned).
3299 #ifndef QSORT_BREAK_EVEN
3300 #define QSORT_BREAK_EVEN 6
3303 /* ************************************************************* Data Types */
3305 /* hold left and right index values of a partition waiting to be sorted (the
3306 partition includes both left and right - right is NOT one past the end or
3307 anything like that).
3309 struct partition_stack_entry {
3312 #ifdef QSORT_ORDER_GUESS
3313 int qsort_break_even;
3317 /* ******************************************************* Shorthand Macros */
3319 /* Note that these macros will be used from inside the qsort function where
3320 we happen to know that the variable 'elt_size' contains the size of an
3321 array element and the variable 'temp' points to enough space to hold a
3322 temp element and the variable 'array' points to the array being sorted
3323 and 'compare' is the pointer to the compare routine.
3325 Also note that there are very many highly architecture specific ways
3326 these might be sped up, but this is simply the most generally portable
3327 code I could think of.
3330 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3333 #define qsort_cmp(elt1, elt2) \
3334 ((this->*compare)(array[elt1], array[elt2]))
3336 #define qsort_cmp(elt1, elt2) \
3337 ((*compare)(array[elt1], array[elt2]))
3340 #ifdef QSORT_ORDER_GUESS
3341 #define QSORT_NOTICE_SWAP swapped++;
3343 #define QSORT_NOTICE_SWAP
3346 /* swaps contents of array elements elt1, elt2.
3348 #define qsort_swap(elt1, elt2) \
3351 temp = array[elt1]; \
3352 array[elt1] = array[elt2]; \
3353 array[elt2] = temp; \
3356 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3357 elt3 and elt3 gets elt1.
3359 #define qsort_rotate(elt1, elt2, elt3) \
3362 temp = array[elt1]; \
3363 array[elt1] = array[elt2]; \
3364 array[elt2] = array[elt3]; \
3365 array[elt3] = temp; \
3368 /* ************************************************************ Debug stuff */
3375 return; /* good place to set a breakpoint */
3378 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3381 doqsort_all_asserts(
3385 int (*compare)(const void * elt1, const void * elt2),
3386 int pc_left, int pc_right, int u_left, int u_right)
3390 qsort_assert(pc_left <= pc_right);
3391 qsort_assert(u_right < pc_left);
3392 qsort_assert(pc_right < u_left);
3393 for (i = u_right + 1; i < pc_left; ++i) {
3394 qsort_assert(qsort_cmp(i, pc_left) < 0);
3396 for (i = pc_left; i < pc_right; ++i) {
3397 qsort_assert(qsort_cmp(i, pc_right) == 0);
3399 for (i = pc_right + 1; i < u_left; ++i) {
3400 qsort_assert(qsort_cmp(pc_right, i) < 0);
3404 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3405 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3406 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3410 #define qsort_assert(t) ((void)0)
3412 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3416 /* ****************************************************************** qsort */
3420 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3425 I32 (*compare)(SV *a, SV *b))
3430 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3431 int next_stack_entry = 0;
3435 #ifdef QSORT_ORDER_GUESS
3436 int qsort_break_even;
3440 /* Make sure we actually have work to do.
3442 if (num_elts <= 1) {
3446 /* Setup the initial partition definition and fall into the sorting loop
3449 part_right = (int)(num_elts - 1);
3450 #ifdef QSORT_ORDER_GUESS
3451 qsort_break_even = QSORT_BREAK_EVEN;
3453 #define qsort_break_even QSORT_BREAK_EVEN
3456 if ((part_right - part_left) >= qsort_break_even) {
3457 /* OK, this is gonna get hairy, so lets try to document all the
3458 concepts and abbreviations and variables and what they keep
3461 pc: pivot chunk - the set of array elements we accumulate in the
3462 middle of the partition, all equal in value to the original
3463 pivot element selected. The pc is defined by:
3465 pc_left - the leftmost array index of the pc
3466 pc_right - the rightmost array index of the pc
3468 we start with pc_left == pc_right and only one element
3469 in the pivot chunk (but it can grow during the scan).
3471 u: uncompared elements - the set of elements in the partition
3472 we have not yet compared to the pivot value. There are two
3473 uncompared sets during the scan - one to the left of the pc
3474 and one to the right.
3476 u_right - the rightmost index of the left side's uncompared set
3477 u_left - the leftmost index of the right side's uncompared set
3479 The leftmost index of the left sides's uncompared set
3480 doesn't need its own variable because it is always defined
3481 by the leftmost edge of the whole partition (part_left). The
3482 same goes for the rightmost edge of the right partition
3485 We know there are no uncompared elements on the left once we
3486 get u_right < part_left and no uncompared elements on the
3487 right once u_left > part_right. When both these conditions
3488 are met, we have completed the scan of the partition.
3490 Any elements which are between the pivot chunk and the
3491 uncompared elements should be less than the pivot value on
3492 the left side and greater than the pivot value on the right
3493 side (in fact, the goal of the whole algorithm is to arrange
3494 for that to be true and make the groups of less-than and
3495 greater-then elements into new partitions to sort again).
3497 As you marvel at the complexity of the code and wonder why it
3498 has to be so confusing. Consider some of the things this level
3499 of confusion brings:
3501 Once I do a compare, I squeeze every ounce of juice out of it. I
3502 never do compare calls I don't have to do, and I certainly never
3505 I also never swap any elements unless I can prove there is a
3506 good reason. Many sort algorithms will swap a known value with
3507 an uncompared value just to get things in the right place (or
3508 avoid complexity :-), but that uncompared value, once it gets
3509 compared, may then have to be swapped again. A lot of the
3510 complexity of this code is due to the fact that it never swaps
3511 anything except compared values, and it only swaps them when the
3512 compare shows they are out of position.
3514 int pc_left, pc_right;
3515 int u_right, u_left;
3519 pc_left = ((part_left + part_right) / 2);
3521 u_right = pc_left - 1;
3522 u_left = pc_right + 1;
3524 /* Qsort works best when the pivot value is also the median value
3525 in the partition (unfortunately you can't find the median value
3526 without first sorting :-), so to give the algorithm a helping
3527 hand, we pick 3 elements and sort them and use the median value
3528 of that tiny set as the pivot value.
3530 Some versions of qsort like to use the left middle and right as
3531 the 3 elements to sort so they can insure the ends of the
3532 partition will contain values which will stop the scan in the
3533 compare loop, but when you have to call an arbitrarily complex
3534 routine to do a compare, its really better to just keep track of
3535 array index values to know when you hit the edge of the
3536 partition and avoid the extra compare. An even better reason to
3537 avoid using a compare call is the fact that you can drop off the
3538 edge of the array if someone foolishly provides you with an
3539 unstable compare function that doesn't always provide consistent
3542 So, since it is simpler for us to compare the three adjacent
3543 elements in the middle of the partition, those are the ones we
3544 pick here (conveniently pointed at by u_right, pc_left, and
3545 u_left). The values of the left, center, and right elements
3546 are refered to as l c and r in the following comments.
3549 #ifdef QSORT_ORDER_GUESS
3552 s = qsort_cmp(u_right, pc_left);
3555 s = qsort_cmp(pc_left, u_left);
3556 /* if l < c, c < r - already in order - nothing to do */
3558 /* l < c, c == r - already in order, pc grows */
3560 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3562 /* l < c, c > r - need to know more */
3563 s = qsort_cmp(u_right, u_left);
3565 /* l < c, c > r, l < r - swap c & r to get ordered */
3566 qsort_swap(pc_left, u_left);
3567 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3568 } else if (s == 0) {
3569 /* l < c, c > r, l == r - swap c&r, grow pc */
3570 qsort_swap(pc_left, u_left);
3572 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3574 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3575 qsort_rotate(pc_left, u_right, u_left);
3576 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3579 } else if (s == 0) {
3581 s = qsort_cmp(pc_left, u_left);
3583 /* l == c, c < r - already in order, grow pc */
3585 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3586 } else if (s == 0) {
3587 /* l == c, c == r - already in order, grow pc both ways */
3590 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3592 /* l == c, c > r - swap l & r, grow pc */
3593 qsort_swap(u_right, u_left);
3595 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3599 s = qsort_cmp(pc_left, u_left);
3601 /* l > c, c < r - need to know more */
3602 s = qsort_cmp(u_right, u_left);
3604 /* l > c, c < r, l < r - swap l & c to get ordered */
3605 qsort_swap(u_right, pc_left);
3606 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3607 } else if (s == 0) {
3608 /* l > c, c < r, l == r - swap l & c, grow pc */
3609 qsort_swap(u_right, pc_left);
3611 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3613 /* l > c, c < r, l > r - rotate lcr into crl to order */
3614 qsort_rotate(u_right, pc_left, u_left);
3615 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3617 } else if (s == 0) {
3618 /* l > c, c == r - swap ends, grow pc */
3619 qsort_swap(u_right, u_left);
3621 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3623 /* l > c, c > r - swap ends to get in order */
3624 qsort_swap(u_right, u_left);
3625 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3628 /* We now know the 3 middle elements have been compared and
3629 arranged in the desired order, so we can shrink the uncompared
3634 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3636 /* The above massive nested if was the simple part :-). We now have
3637 the middle 3 elements ordered and we need to scan through the
3638 uncompared sets on either side, swapping elements that are on
3639 the wrong side or simply shuffling equal elements around to get
3640 all equal elements into the pivot chunk.
3644 int still_work_on_left;
3645 int still_work_on_right;
3647 /* Scan the uncompared values on the left. If I find a value
3648 equal to the pivot value, move it over so it is adjacent to
3649 the pivot chunk and expand the pivot chunk. If I find a value
3650 less than the pivot value, then just leave it - its already
3651 on the correct side of the partition. If I find a greater
3652 value, then stop the scan.
3654 while (still_work_on_left = (u_right >= part_left)) {
3655 s = qsort_cmp(u_right, pc_left);
3658 } else if (s == 0) {
3660 if (pc_left != u_right) {
3661 qsort_swap(u_right, pc_left);
3667 qsort_assert(u_right < pc_left);
3668 qsort_assert(pc_left <= pc_right);
3669 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3670 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3673 /* Do a mirror image scan of uncompared values on the right
3675 while (still_work_on_right = (u_left <= part_right)) {
3676 s = qsort_cmp(pc_right, u_left);
3679 } else if (s == 0) {
3681 if (pc_right != u_left) {
3682 qsort_swap(pc_right, u_left);
3688 qsort_assert(u_left > pc_right);
3689 qsort_assert(pc_left <= pc_right);
3690 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3691 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3694 if (still_work_on_left) {
3695 /* I know I have a value on the left side which needs to be
3696 on the right side, but I need to know more to decide
3697 exactly the best thing to do with it.
3699 if (still_work_on_right) {
3700 /* I know I have values on both side which are out of
3701 position. This is a big win because I kill two birds
3702 with one swap (so to speak). I can advance the
3703 uncompared pointers on both sides after swapping both
3704 of them into the right place.
3706 qsort_swap(u_right, u_left);
3709 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3711 /* I have an out of position value on the left, but the
3712 right is fully scanned, so I "slide" the pivot chunk
3713 and any less-than values left one to make room for the
3714 greater value over on the right. If the out of position
3715 value is immediately adjacent to the pivot chunk (there
3716 are no less-than values), I can do that with a swap,
3717 otherwise, I have to rotate one of the less than values
3718 into the former position of the out of position value
3719 and the right end of the pivot chunk into the left end
3723 if (pc_left == u_right) {
3724 qsort_swap(u_right, pc_right);
3725 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3727 qsort_rotate(u_right, pc_left, pc_right);
3728 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3733 } else if (still_work_on_right) {
3734 /* Mirror image of complex case above: I have an out of
3735 position value on the right, but the left is fully
3736 scanned, so I need to shuffle things around to make room
3737 for the right value on the left.
3740 if (pc_right == u_left) {
3741 qsort_swap(u_left, pc_left);
3742 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3744 qsort_rotate(pc_right, pc_left, u_left);
3745 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3750 /* No more scanning required on either side of partition,
3751 break out of loop and figure out next set of partitions
3757 /* The elements in the pivot chunk are now in the right place. They
3758 will never move or be compared again. All I have to do is decide
3759 what to do with the stuff to the left and right of the pivot
3762 Notes on the QSORT_ORDER_GUESS ifdef code:
3764 1. If I just built these partitions without swapping any (or
3765 very many) elements, there is a chance that the elements are
3766 already ordered properly (being properly ordered will
3767 certainly result in no swapping, but the converse can't be
3770 2. A (properly written) insertion sort will run faster on
3771 already ordered data than qsort will.
3773 3. Perhaps there is some way to make a good guess about
3774 switching to an insertion sort earlier than partition size 6
3775 (for instance - we could save the partition size on the stack
3776 and increase the size each time we find we didn't swap, thus
3777 switching to insertion sort earlier for partitions with a
3778 history of not swapping).
3780 4. Naturally, if I just switch right away, it will make
3781 artificial benchmarks with pure ascending (or descending)
3782 data look really good, but is that a good reason in general?
3786 #ifdef QSORT_ORDER_GUESS
3788 #if QSORT_ORDER_GUESS == 1
3789 qsort_break_even = (part_right - part_left) + 1;
3791 #if QSORT_ORDER_GUESS == 2
3792 qsort_break_even *= 2;
3794 #if QSORT_ORDER_GUESS == 3
3795 int prev_break = qsort_break_even;
3796 qsort_break_even *= qsort_break_even;
3797 if (qsort_break_even < prev_break) {
3798 qsort_break_even = (part_right - part_left) + 1;
3802 qsort_break_even = QSORT_BREAK_EVEN;
3806 if (part_left < pc_left) {
3807 /* There are elements on the left which need more processing.
3808 Check the right as well before deciding what to do.
3810 if (pc_right < part_right) {
3811 /* We have two partitions to be sorted. Stack the biggest one
3812 and process the smallest one on the next iteration. This
3813 minimizes the stack height by insuring that any additional
3814 stack entries must come from the smallest partition which
3815 (because it is smallest) will have the fewest
3816 opportunities to generate additional stack entries.
3818 if ((part_right - pc_right) > (pc_left - part_left)) {
3819 /* stack the right partition, process the left */
3820 partition_stack[next_stack_entry].left = pc_right + 1;
3821 partition_stack[next_stack_entry].right = part_right;
3822 #ifdef QSORT_ORDER_GUESS
3823 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3825 part_right = pc_left - 1;
3827 /* stack the left partition, process the right */
3828 partition_stack[next_stack_entry].left = part_left;
3829 partition_stack[next_stack_entry].right = pc_left - 1;
3830 #ifdef QSORT_ORDER_GUESS
3831 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3833 part_left = pc_right + 1;
3835 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3838 /* The elements on the left are the only remaining elements
3839 that need sorting, arrange for them to be processed as the
3842 part_right = pc_left - 1;
3844 } else if (pc_right < part_right) {
3845 /* There is only one chunk on the right to be sorted, make it
3846 the new partition and loop back around.
3848 part_left = pc_right + 1;
3850 /* This whole partition wound up in the pivot chunk, so
3851 we need to get a new partition off the stack.
3853 if (next_stack_entry == 0) {
3854 /* the stack is empty - we are done */
3858 part_left = partition_stack[next_stack_entry].left;
3859 part_right = partition_stack[next_stack_entry].right;
3860 #ifdef QSORT_ORDER_GUESS
3861 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3865 /* This partition is too small to fool with qsort complexity, just
3866 do an ordinary insertion sort to minimize overhead.
3869 /* Assume 1st element is in right place already, and start checking
3870 at 2nd element to see where it should be inserted.
3872 for (i = part_left + 1; i <= part_right; ++i) {
3874 /* Scan (backwards - just in case 'i' is already in right place)
3875 through the elements already sorted to see if the ith element
3876 belongs ahead of one of them.
3878 for (j = i - 1; j >= part_left; --j) {
3879 if (qsort_cmp(i, j) >= 0) {
3880 /* i belongs right after j
3887 /* Looks like we really need to move some things
3891 for (k = i - 1; k >= j; --k)
3892 array[k + 1] = array[k];
3897 /* That partition is now sorted, grab the next one, or get out
3898 of the loop if there aren't any more.
3901 if (next_stack_entry == 0) {
3902 /* the stack is empty - we are done */
3906 part_left = partition_stack[next_stack_entry].left;
3907 part_right = partition_stack[next_stack_entry].right;
3908 #ifdef QSORT_ORDER_GUESS
3909 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3914 /* Believe it or not, the array is sorted at this point! */