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 = PL_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);
921 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
922 qsortsv(ORIGMARK+1, max,
923 (PL_op->op_private & OPpLOCALE)
925 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
926 : FUNC_NAME_TO_PTR(sv_cmp_locale))
928 ? FUNC_NAME_TO_PTR(amagic_cmp)
929 : FUNC_NAME_TO_PTR(sv_cmp) ));
933 PL_stack_sp = ORIGMARK + max;
941 if (GIMME == G_ARRAY)
942 return cCONDOP->op_true;
943 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
950 if (GIMME == G_ARRAY) {
951 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
955 SV *targ = PAD_SV(PL_op->op_targ);
957 if ((PL_op->op_private & OPpFLIP_LINENUM)
958 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
960 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
961 if (PL_op->op_flags & OPf_SPECIAL) {
969 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
982 if (GIMME == G_ARRAY) {
988 if (SvNIOKp(left) || !SvPOKp(left) ||
989 (looks_like_number(left) && *SvPVX(left) != '0') )
991 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
992 croak("Range iterator outside integer range");
996 EXTEND_MORTAL(max - i + 1);
997 EXTEND(SP, max - i + 1);
1000 sv = sv_2mortal(newSViv(i++));
1005 SV *final = sv_mortalcopy(right);
1007 char *tmps = SvPV(final, len);
1009 sv = sv_mortalcopy(left);
1010 SvPV_force(sv,PL_na);
1011 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1013 if (strEQ(SvPVX(sv),tmps))
1015 sv = sv_2mortal(newSVsv(sv));
1022 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1024 if ((PL_op->op_private & OPpFLIP_LINENUM)
1025 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1027 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1028 sv_catpv(targ, "E0");
1039 dopoptolabel(char *label)
1043 register PERL_CONTEXT *cx;
1045 for (i = cxstack_ix; i >= 0; i--) {
1047 switch (CxTYPE(cx)) {
1049 if (ckWARN(WARN_UNSAFE))
1050 warner(WARN_UNSAFE, "Exiting substitution via %s",
1051 PL_op_name[PL_op->op_type]);
1054 if (ckWARN(WARN_UNSAFE))
1055 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1056 PL_op_name[PL_op->op_type]);
1059 if (ckWARN(WARN_UNSAFE))
1060 warner(WARN_UNSAFE, "Exiting eval via %s",
1061 PL_op_name[PL_op->op_type]);
1064 if (ckWARN(WARN_UNSAFE))
1065 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1066 PL_op_name[PL_op->op_type]);
1069 if (!cx->blk_loop.label ||
1070 strNE(label, cx->blk_loop.label) ) {
1071 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1072 (long)i, cx->blk_loop.label));
1075 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1085 I32 gimme = block_gimme();
1086 return (gimme == G_VOID) ? G_SCALAR : gimme;
1095 cxix = dopoptosub(cxstack_ix);
1099 switch (cxstack[cxix].blk_gimme) {
1107 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1114 dopoptosub(I32 startingblock)
1117 return dopoptosub_at(cxstack, startingblock);
1121 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1125 register PERL_CONTEXT *cx;
1126 for (i = startingblock; i >= 0; i--) {
1128 switch (CxTYPE(cx)) {
1133 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1141 dopoptoeval(I32 startingblock)
1145 register PERL_CONTEXT *cx;
1146 for (i = startingblock; i >= 0; i--) {
1148 switch (CxTYPE(cx)) {
1152 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1160 dopoptoloop(I32 startingblock)
1164 register PERL_CONTEXT *cx;
1165 for (i = startingblock; i >= 0; i--) {
1167 switch (CxTYPE(cx)) {
1169 if (ckWARN(WARN_UNSAFE))
1170 warner(WARN_UNSAFE, "Exiting substitution via %s",
1171 PL_op_name[PL_op->op_type]);
1174 if (ckWARN(WARN_UNSAFE))
1175 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1176 PL_op_name[PL_op->op_type]);
1179 if (ckWARN(WARN_UNSAFE))
1180 warner(WARN_UNSAFE, "Exiting eval via %s",
1181 PL_op_name[PL_op->op_type]);
1184 if (ckWARN(WARN_UNSAFE))
1185 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1186 PL_op_name[PL_op->op_type]);
1189 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1200 register PERL_CONTEXT *cx;
1204 while (cxstack_ix > cxix) {
1205 cx = &cxstack[cxstack_ix];
1206 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1207 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1208 /* Note: we don't need to restore the base context info till the end. */
1209 switch (CxTYPE(cx)) {
1212 continue; /* not break */
1230 die_where(char *message)
1235 register PERL_CONTEXT *cx;
1240 if (PL_in_eval & 4) {
1242 STRLEN klen = strlen(message);
1244 svp = hv_fetch(ERRHV, message, klen, TRUE);
1247 static char prefix[] = "\t(in cleanup) ";
1249 sv_upgrade(*svp, SVt_IV);
1250 (void)SvIOK_only(*svp);
1253 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1254 sv_catpvn(err, prefix, sizeof(prefix)-1);
1255 sv_catpvn(err, message, klen);
1256 if (ckWARN(WARN_UNSAFE)) {
1257 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1258 warner(WARN_UNSAFE, SvPVX(err)+start);
1265 sv_setpv(ERRSV, message);
1268 message = SvPVx(ERRSV, PL_na);
1270 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1278 if (cxix < cxstack_ix)
1281 POPBLOCK(cx,PL_curpm);
1282 if (CxTYPE(cx) != CXt_EVAL) {
1283 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1288 if (gimme == G_SCALAR)
1289 *++newsp = &PL_sv_undef;
1290 PL_stack_sp = newsp;
1294 if (optype == OP_REQUIRE) {
1295 char* msg = SvPVx(ERRSV, PL_na);
1296 DIE("%s", *msg ? msg : "Compilation failed in require");
1298 return pop_return();
1302 message = SvPVx(ERRSV, PL_na);
1303 PerlIO_printf(PerlIO_stderr(), "%s",message);
1304 PerlIO_flush(PerlIO_stderr());
1313 if (SvTRUE(left) != SvTRUE(right))
1325 RETURNOP(cLOGOP->op_other);
1334 RETURNOP(cLOGOP->op_other);
1340 register I32 cxix = dopoptosub(cxstack_ix);
1341 register PERL_CONTEXT *cx;
1342 register PERL_CONTEXT *ccstack = cxstack;
1343 PERL_SI *top_si = PL_curstackinfo;
1354 /* we may be in a higher stacklevel, so dig down deeper */
1355 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1356 top_si = top_si->si_prev;
1357 ccstack = top_si->si_cxstack;
1358 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1361 if (GIMME != G_ARRAY)
1365 if (PL_DBsub && cxix >= 0 &&
1366 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1370 cxix = dopoptosub_at(ccstack, cxix - 1);
1373 cx = &ccstack[cxix];
1374 if (CxTYPE(cx) == CXt_SUB) {
1375 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1376 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1377 field below is defined for any cx. */
1378 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1379 cx = &ccstack[dbcxix];
1382 if (GIMME != G_ARRAY) {
1383 hv = cx->blk_oldcop->cop_stash;
1385 PUSHs(&PL_sv_undef);
1388 sv_setpv(TARG, HvNAME(hv));
1394 hv = cx->blk_oldcop->cop_stash;
1396 PUSHs(&PL_sv_undef);
1398 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1399 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1400 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1403 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1405 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1406 PUSHs(sv_2mortal(sv));
1407 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1410 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1411 PUSHs(sv_2mortal(newSViv(0)));
1413 gimme = (I32)cx->blk_gimme;
1414 if (gimme == G_VOID)
1415 PUSHs(&PL_sv_undef);
1417 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1418 if (CxTYPE(cx) == CXt_EVAL) {
1419 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1420 PUSHs(cx->blk_eval.cur_text);
1423 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1424 /* Require, put the name. */
1425 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1429 else if (CxTYPE(cx) == CXt_SUB &&
1430 cx->blk_sub.hasargs &&
1431 PL_curcop->cop_stash == PL_debstash)
1433 AV *ary = cx->blk_sub.argarray;
1434 int off = AvARRAY(ary) - AvALLOC(ary);
1438 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1441 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1444 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1445 av_extend(PL_dbargs, AvFILLp(ary) + off);
1446 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1447 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1453 sortcv(SV *a, SV *b)
1456 I32 oldsaveix = PL_savestack_ix;
1457 I32 oldscopeix = PL_scopestack_ix;
1459 GvSV(PL_firstgv) = a;
1460 GvSV(PL_secondgv) = b;
1461 PL_stack_sp = PL_stack_base;
1464 if (PL_stack_sp != PL_stack_base + 1)
1465 croak("Sort subroutine didn't return single value");
1466 if (!SvNIOKp(*PL_stack_sp))
1467 croak("Sort subroutine didn't return a numeric value");
1468 result = SvIV(*PL_stack_sp);
1469 while (PL_scopestack_ix > oldscopeix) {
1472 leave_scope(oldsaveix);
1485 sv_reset(tmps, PL_curcop->cop_stash);
1497 PL_curcop = (COP*)PL_op;
1498 TAINT_NOT; /* Each statement is presumed innocent */
1499 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1502 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1506 register PERL_CONTEXT *cx;
1507 I32 gimme = G_ARRAY;
1514 DIE("No DB::DB routine defined");
1516 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1528 push_return(PL_op->op_next);
1529 PUSHBLOCK(cx, CXt_SUB, SP);
1532 (void)SvREFCNT_inc(cv);
1533 SAVESPTR(PL_curpad);
1534 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1535 RETURNOP(CvSTART(cv));
1549 register PERL_CONTEXT *cx;
1550 I32 gimme = GIMME_V;
1557 if (PL_op->op_flags & OPf_SPECIAL)
1558 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1560 #endif /* USE_THREADS */
1561 if (PL_op->op_targ) {
1562 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1567 (void)save_scalar(gv);
1568 svp = &GvSV(gv); /* symbol table variable */
1573 PUSHBLOCK(cx, CXt_LOOP, SP);
1574 PUSHLOOP(cx, svp, MARK);
1575 if (PL_op->op_flags & OPf_STACKED) {
1576 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1577 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1579 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1580 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1581 if (SvNV(sv) < IV_MIN ||
1582 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1583 croak("Range iterator outside integer range");
1584 cx->blk_loop.iterix = SvIV(sv);
1585 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1588 cx->blk_loop.iterlval = newSVsv(sv);
1592 cx->blk_loop.iterary = PL_curstack;
1593 AvFILLp(PL_curstack) = SP - PL_stack_base;
1594 cx->blk_loop.iterix = MARK - PL_stack_base;
1603 register PERL_CONTEXT *cx;
1604 I32 gimme = GIMME_V;
1610 PUSHBLOCK(cx, CXt_LOOP, SP);
1611 PUSHLOOP(cx, 0, SP);
1619 register PERL_CONTEXT *cx;
1620 struct block_loop cxloop;
1628 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1631 if (gimme == G_VOID)
1633 else if (gimme == G_SCALAR) {
1635 *++newsp = sv_mortalcopy(*SP);
1637 *++newsp = &PL_sv_undef;
1641 *++newsp = sv_mortalcopy(*++mark);
1642 TAINT_NOT; /* Each item is independent */
1648 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1649 PL_curpm = newpm; /* ... and pop $1 et al */
1661 register PERL_CONTEXT *cx;
1662 struct block_sub cxsub;
1663 bool popsub2 = FALSE;
1669 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1670 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1671 if (cxstack_ix > PL_sortcxix)
1672 dounwind(PL_sortcxix);
1673 AvARRAY(PL_curstack)[1] = *SP;
1674 PL_stack_sp = PL_stack_base + 1;
1679 cxix = dopoptosub(cxstack_ix);
1681 DIE("Can't return outside a subroutine");
1682 if (cxix < cxstack_ix)
1686 switch (CxTYPE(cx)) {
1688 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1693 if (optype == OP_REQUIRE &&
1694 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1696 /* Unassume the success we assumed earlier. */
1697 char *name = cx->blk_eval.old_name;
1698 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1699 DIE("%s did not return a true value", name);
1703 DIE("panic: return");
1707 if (gimme == G_SCALAR) {
1710 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1712 *++newsp = SvREFCNT_inc(*SP);
1717 *++newsp = sv_mortalcopy(*SP);
1720 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1722 *++newsp = sv_mortalcopy(*SP);
1724 *++newsp = &PL_sv_undef;
1726 else if (gimme == G_ARRAY) {
1727 while (++MARK <= SP) {
1728 *++newsp = (popsub2 && SvTEMP(*MARK))
1729 ? *MARK : sv_mortalcopy(*MARK);
1730 TAINT_NOT; /* Each item is independent */
1733 PL_stack_sp = newsp;
1735 /* Stack values are safe: */
1737 POPSUB2(); /* release CV and @_ ... */
1739 PL_curpm = newpm; /* ... and pop $1 et al */
1742 return pop_return();
1749 register PERL_CONTEXT *cx;
1750 struct block_loop cxloop;
1751 struct block_sub cxsub;
1758 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1760 if (PL_op->op_flags & OPf_SPECIAL) {
1761 cxix = dopoptoloop(cxstack_ix);
1763 DIE("Can't \"last\" outside a block");
1766 cxix = dopoptolabel(cPVOP->op_pv);
1768 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1770 if (cxix < cxstack_ix)
1774 switch (CxTYPE(cx)) {
1776 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1778 nextop = cxloop.last_op->op_next;
1781 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1783 nextop = pop_return();
1787 nextop = pop_return();
1794 if (gimme == G_SCALAR) {
1796 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1797 ? *SP : sv_mortalcopy(*SP);
1799 *++newsp = &PL_sv_undef;
1801 else if (gimme == G_ARRAY) {
1802 while (++MARK <= SP) {
1803 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1804 ? *MARK : sv_mortalcopy(*MARK);
1805 TAINT_NOT; /* Each item is independent */
1811 /* Stack values are safe: */
1814 POPLOOP2(); /* release loop vars ... */
1818 POPSUB2(); /* release CV and @_ ... */
1821 PL_curpm = newpm; /* ... and pop $1 et al */
1830 register PERL_CONTEXT *cx;
1833 if (PL_op->op_flags & OPf_SPECIAL) {
1834 cxix = dopoptoloop(cxstack_ix);
1836 DIE("Can't \"next\" outside a block");
1839 cxix = dopoptolabel(cPVOP->op_pv);
1841 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1843 if (cxix < cxstack_ix)
1847 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1848 LEAVE_SCOPE(oldsave);
1849 return cx->blk_loop.next_op;
1855 register PERL_CONTEXT *cx;
1858 if (PL_op->op_flags & OPf_SPECIAL) {
1859 cxix = dopoptoloop(cxstack_ix);
1861 DIE("Can't \"redo\" outside a block");
1864 cxix = dopoptolabel(cPVOP->op_pv);
1866 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1868 if (cxix < cxstack_ix)
1872 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1873 LEAVE_SCOPE(oldsave);
1874 return cx->blk_loop.redo_op;
1878 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1882 static char too_deep[] = "Target of goto is too deeply nested";
1886 if (o->op_type == OP_LEAVE ||
1887 o->op_type == OP_SCOPE ||
1888 o->op_type == OP_LEAVELOOP ||
1889 o->op_type == OP_LEAVETRY)
1891 *ops++ = cUNOPo->op_first;
1896 if (o->op_flags & OPf_KIDS) {
1898 /* First try all the kids at this level, since that's likeliest. */
1899 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1900 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1901 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1904 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1905 if (kid == PL_lastgotoprobe)
1907 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1909 (ops[-1]->op_type != OP_NEXTSTATE &&
1910 ops[-1]->op_type != OP_DBSTATE)))
1912 if (o = dofindlabel(kid, label, ops, oplimit))
1922 return pp_goto(ARGS);
1931 register PERL_CONTEXT *cx;
1932 #define GOTO_DEPTH 64
1933 OP *enterops[GOTO_DEPTH];
1935 int do_dump = (PL_op->op_type == OP_DUMP);
1938 if (PL_op->op_flags & OPf_STACKED) {
1941 /* This egregious kludge implements goto &subroutine */
1942 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1944 register PERL_CONTEXT *cx;
1945 CV* cv = (CV*)SvRV(sv);
1949 int arg_was_real = 0;
1952 if (!CvROOT(cv) && !CvXSUB(cv)) {
1957 /* autoloaded stub? */
1958 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1960 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1961 GvNAMELEN(gv), FALSE);
1962 if (autogv && (cv = GvCV(autogv)))
1964 tmpstr = sv_newmortal();
1965 gv_efullname3(tmpstr, gv, Nullch);
1966 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1968 DIE("Goto undefined subroutine");
1971 /* First do some returnish stuff. */
1972 cxix = dopoptosub(cxstack_ix);
1974 DIE("Can't goto subroutine outside a subroutine");
1975 if (cxix < cxstack_ix)
1978 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1979 DIE("Can't goto subroutine from an eval-string");
1981 if (CxTYPE(cx) == CXt_SUB &&
1982 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1983 AV* av = cx->blk_sub.argarray;
1985 items = AvFILLp(av) + 1;
1987 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1988 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1989 PL_stack_sp += items;
1991 SvREFCNT_dec(GvAV(PL_defgv));
1992 GvAV(PL_defgv) = cx->blk_sub.savearray;
1993 #endif /* USE_THREADS */
1996 AvREAL_off(av); /* so av_clear() won't clobber elts */
2000 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2004 av = (AV*)PL_curpad[0];
2006 av = GvAV(PL_defgv);
2008 items = AvFILLp(av) + 1;
2010 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2011 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2012 PL_stack_sp += items;
2014 if (CxTYPE(cx) == CXt_SUB &&
2015 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2016 SvREFCNT_dec(cx->blk_sub.cv);
2017 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2018 LEAVE_SCOPE(oldsave);
2020 /* Now do some callish stuff. */
2023 if (CvOLDSTYLE(cv)) {
2024 I32 (*fp3)_((int,int,int));
2029 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2030 items = (*fp3)(CvXSUBANY(cv).any_i32,
2031 mark - PL_stack_base + 1,
2033 SP = PL_stack_base + items;
2039 PL_stack_sp--; /* There is no cv arg. */
2040 /* Push a mark for the start of arglist */
2042 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2043 /* Pop the current context like a decent sub should */
2044 POPBLOCK(cx, PL_curpm);
2045 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2048 return pop_return();
2051 AV* padlist = CvPADLIST(cv);
2052 SV** svp = AvARRAY(padlist);
2053 if (CxTYPE(cx) == CXt_EVAL) {
2054 PL_in_eval = cx->blk_eval.old_in_eval;
2055 PL_eval_root = cx->blk_eval.old_eval_root;
2056 cx->cx_type = CXt_SUB;
2057 cx->blk_sub.hasargs = 0;
2059 cx->blk_sub.cv = cv;
2060 cx->blk_sub.olddepth = CvDEPTH(cv);
2062 if (CvDEPTH(cv) < 2)
2063 (void)SvREFCNT_inc(cv);
2064 else { /* save temporaries on recursion? */
2065 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2066 sub_crush_depth(cv);
2067 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2068 AV *newpad = newAV();
2069 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2070 I32 ix = AvFILLp((AV*)svp[1]);
2071 svp = AvARRAY(svp[0]);
2072 for ( ;ix > 0; ix--) {
2073 if (svp[ix] != &PL_sv_undef) {
2074 char *name = SvPVX(svp[ix]);
2075 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2078 /* outer lexical or anon code */
2079 av_store(newpad, ix,
2080 SvREFCNT_inc(oldpad[ix]) );
2082 else { /* our own lexical */
2084 av_store(newpad, ix, sv = (SV*)newAV());
2085 else if (*name == '%')
2086 av_store(newpad, ix, sv = (SV*)newHV());
2088 av_store(newpad, ix, sv = NEWSV(0,0));
2093 av_store(newpad, ix, sv = NEWSV(0,0));
2097 if (cx->blk_sub.hasargs) {
2100 av_store(newpad, 0, (SV*)av);
2101 AvFLAGS(av) = AVf_REIFY;
2103 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2104 AvFILLp(padlist) = CvDEPTH(cv);
2105 svp = AvARRAY(padlist);
2109 if (!cx->blk_sub.hasargs) {
2110 AV* av = (AV*)PL_curpad[0];
2112 items = AvFILLp(av) + 1;
2114 /* Mark is at the end of the stack. */
2116 Copy(AvARRAY(av), SP + 1, items, SV*);
2121 #endif /* USE_THREADS */
2122 SAVESPTR(PL_curpad);
2123 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2125 if (cx->blk_sub.hasargs)
2126 #endif /* USE_THREADS */
2128 AV* av = (AV*)PL_curpad[0];
2132 cx->blk_sub.savearray = GvAV(PL_defgv);
2133 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2134 #endif /* USE_THREADS */
2135 cx->blk_sub.argarray = av;
2138 if (items >= AvMAX(av) + 1) {
2140 if (AvARRAY(av) != ary) {
2141 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2142 SvPVX(av) = (char*)ary;
2144 if (items >= AvMAX(av) + 1) {
2145 AvMAX(av) = items - 1;
2146 Renew(ary,items+1,SV*);
2148 SvPVX(av) = (char*)ary;
2151 Copy(mark,AvARRAY(av),items,SV*);
2152 AvFILLp(av) = items - 1;
2153 /* preserve @_ nature */
2164 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2166 * We do not care about using sv to call CV;
2167 * it's for informational purposes only.
2169 SV *sv = GvSV(PL_DBsub);
2172 if (PERLDB_SUB_NN) {
2173 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2176 gv_efullname3(sv, CvGV(cv), Nullch);
2179 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2180 PUSHMARK( PL_stack_sp );
2181 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2185 RETURNOP(CvSTART(cv));
2189 label = SvPV(sv,PL_na);
2191 else if (PL_op->op_flags & OPf_SPECIAL) {
2193 DIE("goto must have label");
2196 label = cPVOP->op_pv;
2198 if (label && *label) {
2203 PL_lastgotoprobe = 0;
2205 for (ix = cxstack_ix; ix >= 0; ix--) {
2207 switch (CxTYPE(cx)) {
2209 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2212 gotoprobe = cx->blk_oldcop->op_sibling;
2218 gotoprobe = cx->blk_oldcop->op_sibling;
2220 gotoprobe = PL_main_root;
2223 if (CvDEPTH(cx->blk_sub.cv)) {
2224 gotoprobe = CvROOT(cx->blk_sub.cv);
2229 DIE("Can't \"goto\" outside a block");
2233 gotoprobe = PL_main_root;
2236 retop = dofindlabel(gotoprobe, label,
2237 enterops, enterops + GOTO_DEPTH);
2240 PL_lastgotoprobe = gotoprobe;
2243 DIE("Can't find label %s", label);
2245 /* pop unwanted frames */
2247 if (ix < cxstack_ix) {
2254 oldsave = PL_scopestack[PL_scopestack_ix];
2255 LEAVE_SCOPE(oldsave);
2258 /* push wanted frames */
2260 if (*enterops && enterops[1]) {
2262 for (ix = 1; enterops[ix]; ix++) {
2263 PL_op = enterops[ix];
2264 /* Eventually we may want to stack the needed arguments
2265 * for each op. For now, we punt on the hard ones. */
2266 if (PL_op->op_type == OP_ENTERITER)
2267 DIE("Can't \"goto\" into the middle of a foreach loop",
2269 (CALLOP->op_ppaddr)(ARGS);
2277 if (!retop) retop = PL_main_start;
2279 PL_restartop = retop;
2280 PL_do_undump = TRUE;
2284 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2285 PL_do_undump = FALSE;
2301 if (anum == 1 && VMSISH_EXIT)
2306 PUSHs(&PL_sv_undef);
2314 double value = SvNVx(GvSV(cCOP->cop_gv));
2315 register I32 match = I_32(value);
2318 if (((double)match) > value)
2319 --match; /* was fractional--truncate other way */
2321 match -= cCOP->uop.scop.scop_offset;
2324 else if (match > cCOP->uop.scop.scop_max)
2325 match = cCOP->uop.scop.scop_max;
2326 PL_op = cCOP->uop.scop.scop_next[match];
2336 PL_op = PL_op->op_next; /* can't assume anything */
2338 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2339 match -= cCOP->uop.scop.scop_offset;
2342 else if (match > cCOP->uop.scop.scop_max)
2343 match = cCOP->uop.scop.scop_max;
2344 PL_op = cCOP->uop.scop.scop_next[match];
2353 save_lines(AV *array, SV *sv)
2355 register char *s = SvPVX(sv);
2356 register char *send = SvPVX(sv) + SvCUR(sv);
2358 register I32 line = 1;
2360 while (s && s < send) {
2361 SV *tmpstr = NEWSV(85,0);
2363 sv_upgrade(tmpstr, SVt_PVMG);
2364 t = strchr(s, '\n');
2370 sv_setpvn(tmpstr, s, t - s);
2371 av_store(array, line++, tmpstr);
2386 assert(CATCH_GET == TRUE);
2387 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2391 default: /* topmost level handles it */
2400 PL_op = PL_restartop;
2413 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2414 /* sv Text to convert to OP tree. */
2415 /* startop op_free() this to undo. */
2416 /* code Short string id of the caller. */
2418 dSP; /* Make POPBLOCK work. */
2421 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2424 OP *oop = PL_op, *rop;
2425 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2431 /* switch to eval mode */
2433 if (PL_curcop == &PL_compiling) {
2434 SAVESPTR(PL_compiling.cop_stash);
2435 PL_compiling.cop_stash = PL_curstash;
2437 SAVESPTR(PL_compiling.cop_filegv);
2438 SAVEI16(PL_compiling.cop_line);
2439 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2440 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2441 PL_compiling.cop_line = 1;
2442 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2443 deleting the eval's FILEGV from the stash before gv_check() runs
2444 (i.e. before run-time proper). To work around the coredump that
2445 ensues, we always turn GvMULTI_on for any globals that were
2446 introduced within evals. See force_ident(). GSAR 96-10-12 */
2447 safestr = savepv(tmpbuf);
2448 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2450 #ifdef OP_IN_REGISTER
2458 PL_op->op_type = OP_ENTEREVAL;
2459 PL_op->op_flags = 0; /* Avoid uninit warning. */
2460 PUSHBLOCK(cx, CXt_EVAL, SP);
2461 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2462 rop = doeval(G_SCALAR, startop);
2463 POPBLOCK(cx,PL_curpm);
2466 (*startop)->op_type = OP_NULL;
2467 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2469 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2471 if (PL_curcop == &PL_compiling)
2472 PL_compiling.op_private = PL_hints;
2473 #ifdef OP_IN_REGISTER
2479 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2481 doeval(int gimme, OP** startop)
2494 /* set up a scratch pad */
2497 SAVESPTR(PL_curpad);
2498 SAVESPTR(PL_comppad);
2499 SAVESPTR(PL_comppad_name);
2500 SAVEI32(PL_comppad_name_fill);
2501 SAVEI32(PL_min_intro_pending);
2502 SAVEI32(PL_max_intro_pending);
2505 for (i = cxstack_ix - 1; i >= 0; i--) {
2506 PERL_CONTEXT *cx = &cxstack[i];
2507 if (CxTYPE(cx) == CXt_EVAL)
2509 else if (CxTYPE(cx) == CXt_SUB) {
2510 caller = cx->blk_sub.cv;
2515 SAVESPTR(PL_compcv);
2516 PL_compcv = (CV*)NEWSV(1104,0);
2517 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2518 CvUNIQUE_on(PL_compcv);
2520 CvOWNER(PL_compcv) = 0;
2521 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2522 MUTEX_INIT(CvMUTEXP(PL_compcv));
2523 #endif /* USE_THREADS */
2525 PL_comppad = newAV();
2526 av_push(PL_comppad, Nullsv);
2527 PL_curpad = AvARRAY(PL_comppad);
2528 PL_comppad_name = newAV();
2529 PL_comppad_name_fill = 0;
2530 PL_min_intro_pending = 0;
2533 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2534 PL_curpad[0] = (SV*)newAV();
2535 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2536 #endif /* USE_THREADS */
2538 comppadlist = newAV();
2539 AvREAL_off(comppadlist);
2540 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2541 av_store(comppadlist, 1, (SV*)PL_comppad);
2542 CvPADLIST(PL_compcv) = comppadlist;
2544 if (!saveop || saveop->op_type != OP_REQUIRE)
2545 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2547 SAVEFREESV(PL_compcv);
2549 /* make sure we compile in the right package */
2551 newstash = PL_curcop->cop_stash;
2552 if (PL_curstash != newstash) {
2553 SAVESPTR(PL_curstash);
2554 PL_curstash = newstash;
2556 SAVESPTR(PL_beginav);
2557 PL_beginav = newAV();
2558 SAVEFREESV(PL_beginav);
2560 /* try to compile it */
2562 PL_eval_root = Nullop;
2564 PL_curcop = &PL_compiling;
2565 PL_curcop->cop_arybase = 0;
2566 SvREFCNT_dec(PL_rs);
2567 PL_rs = newSVpv("\n", 1);
2568 if (saveop && saveop->op_flags & OPf_SPECIAL)
2572 if (yyparse() || PL_error_count || !PL_eval_root) {
2576 I32 optype = 0; /* Might be reset by POPEVAL. */
2580 op_free(PL_eval_root);
2581 PL_eval_root = Nullop;
2583 SP = PL_stack_base + POPMARK; /* pop original mark */
2585 POPBLOCK(cx,PL_curpm);
2591 if (optype == OP_REQUIRE) {
2592 char* msg = SvPVx(ERRSV, PL_na);
2593 DIE("%s", *msg ? msg : "Compilation failed in require");
2594 } else if (startop) {
2595 char* msg = SvPVx(ERRSV, PL_na);
2597 POPBLOCK(cx,PL_curpm);
2599 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2601 SvREFCNT_dec(PL_rs);
2602 PL_rs = SvREFCNT_inc(PL_nrs);
2604 MUTEX_LOCK(&PL_eval_mutex);
2606 COND_SIGNAL(&PL_eval_cond);
2607 MUTEX_UNLOCK(&PL_eval_mutex);
2608 #endif /* USE_THREADS */
2611 SvREFCNT_dec(PL_rs);
2612 PL_rs = SvREFCNT_inc(PL_nrs);
2613 PL_compiling.cop_line = 0;
2615 *startop = PL_eval_root;
2616 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2617 CvOUTSIDE(PL_compcv) = Nullcv;
2619 SAVEFREEOP(PL_eval_root);
2621 scalarvoid(PL_eval_root);
2622 else if (gimme & G_ARRAY)
2625 scalar(PL_eval_root);
2627 DEBUG_x(dump_eval());
2629 /* Register with debugger: */
2630 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2631 CV *cv = perl_get_cv("DB::postponed", FALSE);
2635 XPUSHs((SV*)PL_compiling.cop_filegv);
2637 perl_call_sv((SV*)cv, G_DISCARD);
2641 /* compiled okay, so do it */
2643 CvDEPTH(PL_compcv) = 1;
2644 SP = PL_stack_base + POPMARK; /* pop original mark */
2645 PL_op = saveop; /* The caller may need it. */
2647 MUTEX_LOCK(&PL_eval_mutex);
2649 COND_SIGNAL(&PL_eval_cond);
2650 MUTEX_UNLOCK(&PL_eval_mutex);
2651 #endif /* USE_THREADS */
2653 RETURNOP(PL_eval_start);
2659 register PERL_CONTEXT *cx;
2664 SV *namesv = Nullsv;
2666 I32 gimme = G_SCALAR;
2667 PerlIO *tryrsfp = 0;
2670 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2671 SET_NUMERIC_STANDARD();
2672 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2673 DIE("Perl %s required--this is only version %s, stopped",
2674 SvPV(sv,PL_na),PL_patchlevel);
2677 name = SvPV(sv, len);
2678 if (!(name && len > 0 && *name))
2679 DIE("Null filename used");
2680 TAINT_PROPER("require");
2681 if (PL_op->op_type == OP_REQUIRE &&
2682 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2683 *svp != &PL_sv_undef)
2686 /* prepare to compile file */
2691 (name[1] == '.' && name[2] == '/')))
2693 || (name[0] && name[1] == ':')
2696 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2699 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2700 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2705 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2708 AV *ar = GvAVn(PL_incgv);
2712 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2715 namesv = NEWSV(806, 0);
2716 for (i = 0; i <= AvFILL(ar); i++) {
2717 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2720 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2722 sv_setpv(namesv, unixdir);
2723 sv_catpv(namesv, unixname);
2725 sv_setpvf(namesv, "%s/%s", dir, name);
2727 TAINT_PROPER("require");
2728 tryname = SvPVX(namesv);
2729 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2731 if (tryname[0] == '.' && tryname[1] == '/')
2738 SAVESPTR(PL_compiling.cop_filegv);
2739 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2740 SvREFCNT_dec(namesv);
2742 if (PL_op->op_type == OP_REQUIRE) {
2743 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2744 SV *dirmsgsv = NEWSV(0, 0);
2745 AV *ar = GvAVn(PL_incgv);
2747 if (instr(SvPVX(msg), ".h "))
2748 sv_catpv(msg, " (change .h to .ph maybe?)");
2749 if (instr(SvPVX(msg), ".ph "))
2750 sv_catpv(msg, " (did you run h2ph?)");
2751 sv_catpv(msg, " (@INC contains:");
2752 for (i = 0; i <= AvFILL(ar); i++) {
2753 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2754 sv_setpvf(dirmsgsv, " %s", dir);
2755 sv_catsv(msg, dirmsgsv);
2757 sv_catpvn(msg, ")", 1);
2758 SvREFCNT_dec(dirmsgsv);
2765 SETERRNO(0, SS$_NORMAL);
2767 /* Assume success here to prevent recursive requirement. */
2768 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2769 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2773 lex_start(sv_2mortal(newSVpv("",0)));
2774 SAVEGENERICSV(PL_rsfp_filters);
2775 PL_rsfp_filters = Nullav;
2778 name = savepv(name);
2782 SAVEPPTR(PL_compiling.cop_warnings);
2783 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2786 /* switch to eval mode */
2788 push_return(PL_op->op_next);
2789 PUSHBLOCK(cx, CXt_EVAL, SP);
2790 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2792 SAVEI16(PL_compiling.cop_line);
2793 PL_compiling.cop_line = 0;
2797 MUTEX_LOCK(&PL_eval_mutex);
2798 if (PL_eval_owner && PL_eval_owner != thr)
2799 while (PL_eval_owner)
2800 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2801 PL_eval_owner = thr;
2802 MUTEX_UNLOCK(&PL_eval_mutex);
2803 #endif /* USE_THREADS */
2804 return DOCATCH(doeval(G_SCALAR, NULL));
2809 return pp_require(ARGS);
2815 register PERL_CONTEXT *cx;
2817 I32 gimme = GIMME_V, was = PL_sub_generation;
2818 char tmpbuf[TYPE_DIGITS(long) + 12];
2823 if (!SvPV(sv,len) || !len)
2825 TAINT_PROPER("eval");
2831 /* switch to eval mode */
2833 SAVESPTR(PL_compiling.cop_filegv);
2834 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2835 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2836 PL_compiling.cop_line = 1;
2837 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2838 deleting the eval's FILEGV from the stash before gv_check() runs
2839 (i.e. before run-time proper). To work around the coredump that
2840 ensues, we always turn GvMULTI_on for any globals that were
2841 introduced within evals. See force_ident(). GSAR 96-10-12 */
2842 safestr = savepv(tmpbuf);
2843 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2845 PL_hints = PL_op->op_targ;
2846 SAVEPPTR(PL_compiling.cop_warnings);
2847 if (PL_compiling.cop_warnings != WARN_ALL
2848 && PL_compiling.cop_warnings != WARN_NONE){
2849 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2850 SAVEFREESV(PL_compiling.cop_warnings) ;
2853 push_return(PL_op->op_next);
2854 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2855 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2857 /* prepare to compile string */
2859 if (PERLDB_LINE && PL_curstash != PL_debstash)
2860 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2863 MUTEX_LOCK(&PL_eval_mutex);
2864 if (PL_eval_owner && PL_eval_owner != thr)
2865 while (PL_eval_owner)
2866 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2867 PL_eval_owner = thr;
2868 MUTEX_UNLOCK(&PL_eval_mutex);
2869 #endif /* USE_THREADS */
2870 ret = doeval(gimme, NULL);
2871 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2872 && ret != PL_op->op_next) { /* Successive compilation. */
2873 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2875 return DOCATCH(ret);
2885 register PERL_CONTEXT *cx;
2887 U8 save_flags = PL_op -> op_flags;
2892 retop = pop_return();
2895 if (gimme == G_VOID)
2897 else if (gimme == G_SCALAR) {
2900 if (SvFLAGS(TOPs) & SVs_TEMP)
2903 *MARK = sv_mortalcopy(TOPs);
2907 *MARK = &PL_sv_undef;
2911 /* in case LEAVE wipes old return values */
2912 for (mark = newsp + 1; mark <= SP; mark++) {
2913 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2914 *mark = sv_mortalcopy(*mark);
2915 TAINT_NOT; /* Each item is independent */
2919 PL_curpm = newpm; /* Don't pop $1 et al till now */
2922 * Closures mentioned at top level of eval cannot be referenced
2923 * again, and their presence indirectly causes a memory leak.
2924 * (Note that the fact that compcv and friends are still set here
2925 * is, AFAIK, an accident.) --Chip
2927 if (AvFILLp(PL_comppad_name) >= 0) {
2928 SV **svp = AvARRAY(PL_comppad_name);
2930 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2932 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2934 svp[ix] = &PL_sv_undef;
2938 SvREFCNT_dec(CvOUTSIDE(sv));
2939 CvOUTSIDE(sv) = Nullcv;
2952 assert(CvDEPTH(PL_compcv) == 1);
2954 CvDEPTH(PL_compcv) = 0;
2957 if (optype == OP_REQUIRE &&
2958 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2960 /* Unassume the success we assumed earlier. */
2961 char *name = cx->blk_eval.old_name;
2962 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2963 retop = die("%s did not return a true value", name);
2964 /* die_where() did LEAVE, or we won't be here */
2968 if (!(save_flags & OPf_SPECIAL))
2978 register PERL_CONTEXT *cx;
2979 I32 gimme = GIMME_V;
2984 push_return(cLOGOP->op_other->op_next);
2985 PUSHBLOCK(cx, CXt_EVAL, SP);
2987 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2992 return DOCATCH(PL_op->op_next);
3002 register PERL_CONTEXT *cx;
3010 if (gimme == G_VOID)
3012 else if (gimme == G_SCALAR) {
3015 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3018 *MARK = sv_mortalcopy(TOPs);
3022 *MARK = &PL_sv_undef;
3027 /* in case LEAVE wipes old return values */
3028 for (mark = newsp + 1; mark <= SP; mark++) {
3029 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3030 *mark = sv_mortalcopy(*mark);
3031 TAINT_NOT; /* Each item is independent */
3035 PL_curpm = newpm; /* Don't pop $1 et al till now */
3046 register char *s = SvPV_force(sv, len);
3047 register char *send = s + len;
3048 register char *base;
3049 register I32 skipspaces = 0;
3052 bool postspace = FALSE;
3060 croak("Null picture in formline");
3062 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3067 *fpc++ = FF_LINEMARK;
3068 noblank = repeat = FALSE;
3086 case ' ': case '\t':
3097 *fpc++ = FF_LITERAL;
3105 *fpc++ = skipspaces;
3109 *fpc++ = FF_NEWLINE;
3113 arg = fpc - linepc + 1;
3120 *fpc++ = FF_LINEMARK;
3121 noblank = repeat = FALSE;
3130 ischop = s[-1] == '^';
3136 arg = (s - base) - 1;
3138 *fpc++ = FF_LITERAL;
3147 *fpc++ = FF_LINEGLOB;
3149 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3150 arg = ischop ? 512 : 0;
3160 arg |= 256 + (s - f);
3162 *fpc++ = s - base; /* fieldsize for FETCH */
3163 *fpc++ = FF_DECIMAL;
3168 bool ismore = FALSE;
3171 while (*++s == '>') ;
3172 prespace = FF_SPACE;
3174 else if (*s == '|') {
3175 while (*++s == '|') ;
3176 prespace = FF_HALFSPACE;
3181 while (*++s == '<') ;
3184 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3188 *fpc++ = s - base; /* fieldsize for FETCH */
3190 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3208 { /* need to jump to the next word */
3210 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3211 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3212 s = SvPVX(sv) + SvCUR(sv) + z;
3214 Copy(fops, s, arg, U16);
3216 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3221 * The rest of this file was derived from source code contributed
3224 * NOTE: this code was derived from Tom Horsley's qsort replacement
3225 * and should not be confused with the original code.
3228 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3230 Permission granted to distribute under the same terms as perl which are
3233 This program is free software; you can redistribute it and/or modify
3234 it under the terms of either:
3236 a) the GNU General Public License as published by the Free
3237 Software Foundation; either version 1, or (at your option) any
3240 b) the "Artistic License" which comes with this Kit.
3242 Details on the perl license can be found in the perl source code which
3243 may be located via the www.perl.com web page.
3245 This is the most wonderfulest possible qsort I can come up with (and
3246 still be mostly portable) My (limited) tests indicate it consistently
3247 does about 20% fewer calls to compare than does the qsort in the Visual
3248 C++ library, other vendors may vary.
3250 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3251 others I invented myself (or more likely re-invented since they seemed
3252 pretty obvious once I watched the algorithm operate for a while).
3254 Most of this code was written while watching the Marlins sweep the Giants
3255 in the 1997 National League Playoffs - no Braves fans allowed to use this
3256 code (just kidding :-).
3258 I realize that if I wanted to be true to the perl tradition, the only
3259 comment in this file would be something like:
3261 ...they shuffled back towards the rear of the line. 'No, not at the
3262 rear!' the slave-driver shouted. 'Three files up. And stay there...
3264 However, I really needed to violate that tradition just so I could keep
3265 track of what happens myself, not to mention some poor fool trying to
3266 understand this years from now :-).
3269 /* ********************************************************** Configuration */
3271 #ifndef QSORT_ORDER_GUESS
3272 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3275 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3276 future processing - a good max upper bound is log base 2 of memory size
3277 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3278 safely be smaller than that since the program is taking up some space and
3279 most operating systems only let you grab some subset of contiguous
3280 memory (not to mention that you are normally sorting data larger than
3281 1 byte element size :-).
3283 #ifndef QSORT_MAX_STACK
3284 #define QSORT_MAX_STACK 32
3287 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3288 Anything bigger and we use qsort. If you make this too small, the qsort
3289 will probably break (or become less efficient), because it doesn't expect
3290 the middle element of a partition to be the same as the right or left -
3291 you have been warned).
3293 #ifndef QSORT_BREAK_EVEN
3294 #define QSORT_BREAK_EVEN 6
3297 /* ************************************************************* Data Types */
3299 /* hold left and right index values of a partition waiting to be sorted (the
3300 partition includes both left and right - right is NOT one past the end or
3301 anything like that).
3303 struct partition_stack_entry {
3306 #ifdef QSORT_ORDER_GUESS
3307 int qsort_break_even;
3311 /* ******************************************************* Shorthand Macros */
3313 /* Note that these macros will be used from inside the qsort function where
3314 we happen to know that the variable 'elt_size' contains the size of an
3315 array element and the variable 'temp' points to enough space to hold a
3316 temp element and the variable 'array' points to the array being sorted
3317 and 'compare' is the pointer to the compare routine.
3319 Also note that there are very many highly architecture specific ways
3320 these might be sped up, but this is simply the most generally portable
3321 code I could think of.
3324 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3327 #define qsort_cmp(elt1, elt2) \
3328 ((this->*compare)(array[elt1], array[elt2]))
3330 #define qsort_cmp(elt1, elt2) \
3331 ((*compare)(array[elt1], array[elt2]))
3334 #ifdef QSORT_ORDER_GUESS
3335 #define QSORT_NOTICE_SWAP swapped++;
3337 #define QSORT_NOTICE_SWAP
3340 /* swaps contents of array elements elt1, elt2.
3342 #define qsort_swap(elt1, elt2) \
3345 temp = array[elt1]; \
3346 array[elt1] = array[elt2]; \
3347 array[elt2] = temp; \
3350 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3351 elt3 and elt3 gets elt1.
3353 #define qsort_rotate(elt1, elt2, elt3) \
3356 temp = array[elt1]; \
3357 array[elt1] = array[elt2]; \
3358 array[elt2] = array[elt3]; \
3359 array[elt3] = temp; \
3362 /* ************************************************************ Debug stuff */
3369 return; /* good place to set a breakpoint */
3372 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3375 doqsort_all_asserts(
3379 int (*compare)(const void * elt1, const void * elt2),
3380 int pc_left, int pc_right, int u_left, int u_right)
3384 qsort_assert(pc_left <= pc_right);
3385 qsort_assert(u_right < pc_left);
3386 qsort_assert(pc_right < u_left);
3387 for (i = u_right + 1; i < pc_left; ++i) {
3388 qsort_assert(qsort_cmp(i, pc_left) < 0);
3390 for (i = pc_left; i < pc_right; ++i) {
3391 qsort_assert(qsort_cmp(i, pc_right) == 0);
3393 for (i = pc_right + 1; i < u_left; ++i) {
3394 qsort_assert(qsort_cmp(pc_right, i) < 0);
3398 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3399 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3400 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3404 #define qsort_assert(t) ((void)0)
3406 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3410 /* ****************************************************************** qsort */
3414 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3419 I32 (*compare)(SV *a, SV *b))
3424 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3425 int next_stack_entry = 0;
3429 #ifdef QSORT_ORDER_GUESS
3430 int qsort_break_even;
3434 /* Make sure we actually have work to do.
3436 if (num_elts <= 1) {
3440 /* Setup the initial partition definition and fall into the sorting loop
3443 part_right = (int)(num_elts - 1);
3444 #ifdef QSORT_ORDER_GUESS
3445 qsort_break_even = QSORT_BREAK_EVEN;
3447 #define qsort_break_even QSORT_BREAK_EVEN
3450 if ((part_right - part_left) >= qsort_break_even) {
3451 /* OK, this is gonna get hairy, so lets try to document all the
3452 concepts and abbreviations and variables and what they keep
3455 pc: pivot chunk - the set of array elements we accumulate in the
3456 middle of the partition, all equal in value to the original
3457 pivot element selected. The pc is defined by:
3459 pc_left - the leftmost array index of the pc
3460 pc_right - the rightmost array index of the pc
3462 we start with pc_left == pc_right and only one element
3463 in the pivot chunk (but it can grow during the scan).
3465 u: uncompared elements - the set of elements in the partition
3466 we have not yet compared to the pivot value. There are two
3467 uncompared sets during the scan - one to the left of the pc
3468 and one to the right.
3470 u_right - the rightmost index of the left side's uncompared set
3471 u_left - the leftmost index of the right side's uncompared set
3473 The leftmost index of the left sides's uncompared set
3474 doesn't need its own variable because it is always defined
3475 by the leftmost edge of the whole partition (part_left). The
3476 same goes for the rightmost edge of the right partition
3479 We know there are no uncompared elements on the left once we
3480 get u_right < part_left and no uncompared elements on the
3481 right once u_left > part_right. When both these conditions
3482 are met, we have completed the scan of the partition.
3484 Any elements which are between the pivot chunk and the
3485 uncompared elements should be less than the pivot value on
3486 the left side and greater than the pivot value on the right
3487 side (in fact, the goal of the whole algorithm is to arrange
3488 for that to be true and make the groups of less-than and
3489 greater-then elements into new partitions to sort again).
3491 As you marvel at the complexity of the code and wonder why it
3492 has to be so confusing. Consider some of the things this level
3493 of confusion brings:
3495 Once I do a compare, I squeeze every ounce of juice out of it. I
3496 never do compare calls I don't have to do, and I certainly never
3499 I also never swap any elements unless I can prove there is a
3500 good reason. Many sort algorithms will swap a known value with
3501 an uncompared value just to get things in the right place (or
3502 avoid complexity :-), but that uncompared value, once it gets
3503 compared, may then have to be swapped again. A lot of the
3504 complexity of this code is due to the fact that it never swaps
3505 anything except compared values, and it only swaps them when the
3506 compare shows they are out of position.
3508 int pc_left, pc_right;
3509 int u_right, u_left;
3513 pc_left = ((part_left + part_right) / 2);
3515 u_right = pc_left - 1;
3516 u_left = pc_right + 1;
3518 /* Qsort works best when the pivot value is also the median value
3519 in the partition (unfortunately you can't find the median value
3520 without first sorting :-), so to give the algorithm a helping
3521 hand, we pick 3 elements and sort them and use the median value
3522 of that tiny set as the pivot value.
3524 Some versions of qsort like to use the left middle and right as
3525 the 3 elements to sort so they can insure the ends of the
3526 partition will contain values which will stop the scan in the
3527 compare loop, but when you have to call an arbitrarily complex
3528 routine to do a compare, its really better to just keep track of
3529 array index values to know when you hit the edge of the
3530 partition and avoid the extra compare. An even better reason to
3531 avoid using a compare call is the fact that you can drop off the
3532 edge of the array if someone foolishly provides you with an
3533 unstable compare function that doesn't always provide consistent
3536 So, since it is simpler for us to compare the three adjacent
3537 elements in the middle of the partition, those are the ones we
3538 pick here (conveniently pointed at by u_right, pc_left, and
3539 u_left). The values of the left, center, and right elements
3540 are refered to as l c and r in the following comments.
3543 #ifdef QSORT_ORDER_GUESS
3546 s = qsort_cmp(u_right, pc_left);
3549 s = qsort_cmp(pc_left, u_left);
3550 /* if l < c, c < r - already in order - nothing to do */
3552 /* l < c, c == r - already in order, pc grows */
3554 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3556 /* l < c, c > r - need to know more */
3557 s = qsort_cmp(u_right, u_left);
3559 /* l < c, c > r, l < r - swap c & r to get ordered */
3560 qsort_swap(pc_left, u_left);
3561 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3562 } else if (s == 0) {
3563 /* l < c, c > r, l == r - swap c&r, grow pc */
3564 qsort_swap(pc_left, u_left);
3566 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3568 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3569 qsort_rotate(pc_left, u_right, u_left);
3570 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3573 } else if (s == 0) {
3575 s = qsort_cmp(pc_left, u_left);
3577 /* l == c, c < r - already in order, grow pc */
3579 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3580 } else if (s == 0) {
3581 /* l == c, c == r - already in order, grow pc both ways */
3584 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3586 /* l == c, c > r - swap l & r, grow pc */
3587 qsort_swap(u_right, u_left);
3589 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3593 s = qsort_cmp(pc_left, u_left);
3595 /* l > c, c < r - need to know more */
3596 s = qsort_cmp(u_right, u_left);
3598 /* l > c, c < r, l < r - swap l & c to get ordered */
3599 qsort_swap(u_right, pc_left);
3600 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3601 } else if (s == 0) {
3602 /* l > c, c < r, l == r - swap l & c, grow pc */
3603 qsort_swap(u_right, pc_left);
3605 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3607 /* l > c, c < r, l > r - rotate lcr into crl to order */
3608 qsort_rotate(u_right, pc_left, u_left);
3609 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3611 } else if (s == 0) {
3612 /* l > c, c == r - swap ends, grow pc */
3613 qsort_swap(u_right, u_left);
3615 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3617 /* l > c, c > r - swap ends to get in order */
3618 qsort_swap(u_right, u_left);
3619 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3622 /* We now know the 3 middle elements have been compared and
3623 arranged in the desired order, so we can shrink the uncompared
3628 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3630 /* The above massive nested if was the simple part :-). We now have
3631 the middle 3 elements ordered and we need to scan through the
3632 uncompared sets on either side, swapping elements that are on
3633 the wrong side or simply shuffling equal elements around to get
3634 all equal elements into the pivot chunk.
3638 int still_work_on_left;
3639 int still_work_on_right;
3641 /* Scan the uncompared values on the left. If I find a value
3642 equal to the pivot value, move it over so it is adjacent to
3643 the pivot chunk and expand the pivot chunk. If I find a value
3644 less than the pivot value, then just leave it - its already
3645 on the correct side of the partition. If I find a greater
3646 value, then stop the scan.
3648 while (still_work_on_left = (u_right >= part_left)) {
3649 s = qsort_cmp(u_right, pc_left);
3652 } else if (s == 0) {
3654 if (pc_left != u_right) {
3655 qsort_swap(u_right, pc_left);
3661 qsort_assert(u_right < pc_left);
3662 qsort_assert(pc_left <= pc_right);
3663 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3664 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3667 /* Do a mirror image scan of uncompared values on the right
3669 while (still_work_on_right = (u_left <= part_right)) {
3670 s = qsort_cmp(pc_right, u_left);
3673 } else if (s == 0) {
3675 if (pc_right != u_left) {
3676 qsort_swap(pc_right, u_left);
3682 qsort_assert(u_left > pc_right);
3683 qsort_assert(pc_left <= pc_right);
3684 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3685 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3688 if (still_work_on_left) {
3689 /* I know I have a value on the left side which needs to be
3690 on the right side, but I need to know more to decide
3691 exactly the best thing to do with it.
3693 if (still_work_on_right) {
3694 /* I know I have values on both side which are out of
3695 position. This is a big win because I kill two birds
3696 with one swap (so to speak). I can advance the
3697 uncompared pointers on both sides after swapping both
3698 of them into the right place.
3700 qsort_swap(u_right, u_left);
3703 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3705 /* I have an out of position value on the left, but the
3706 right is fully scanned, so I "slide" the pivot chunk
3707 and any less-than values left one to make room for the
3708 greater value over on the right. If the out of position
3709 value is immediately adjacent to the pivot chunk (there
3710 are no less-than values), I can do that with a swap,
3711 otherwise, I have to rotate one of the less than values
3712 into the former position of the out of position value
3713 and the right end of the pivot chunk into the left end
3717 if (pc_left == u_right) {
3718 qsort_swap(u_right, pc_right);
3719 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3721 qsort_rotate(u_right, pc_left, pc_right);
3722 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3727 } else if (still_work_on_right) {
3728 /* Mirror image of complex case above: I have an out of
3729 position value on the right, but the left is fully
3730 scanned, so I need to shuffle things around to make room
3731 for the right value on the left.
3734 if (pc_right == u_left) {
3735 qsort_swap(u_left, pc_left);
3736 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3738 qsort_rotate(pc_right, pc_left, u_left);
3739 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3744 /* No more scanning required on either side of partition,
3745 break out of loop and figure out next set of partitions
3751 /* The elements in the pivot chunk are now in the right place. They
3752 will never move or be compared again. All I have to do is decide
3753 what to do with the stuff to the left and right of the pivot
3756 Notes on the QSORT_ORDER_GUESS ifdef code:
3758 1. If I just built these partitions without swapping any (or
3759 very many) elements, there is a chance that the elements are
3760 already ordered properly (being properly ordered will
3761 certainly result in no swapping, but the converse can't be
3764 2. A (properly written) insertion sort will run faster on
3765 already ordered data than qsort will.
3767 3. Perhaps there is some way to make a good guess about
3768 switching to an insertion sort earlier than partition size 6
3769 (for instance - we could save the partition size on the stack
3770 and increase the size each time we find we didn't swap, thus
3771 switching to insertion sort earlier for partitions with a
3772 history of not swapping).
3774 4. Naturally, if I just switch right away, it will make
3775 artificial benchmarks with pure ascending (or descending)
3776 data look really good, but is that a good reason in general?
3780 #ifdef QSORT_ORDER_GUESS
3782 #if QSORT_ORDER_GUESS == 1
3783 qsort_break_even = (part_right - part_left) + 1;
3785 #if QSORT_ORDER_GUESS == 2
3786 qsort_break_even *= 2;
3788 #if QSORT_ORDER_GUESS == 3
3789 int prev_break = qsort_break_even;
3790 qsort_break_even *= qsort_break_even;
3791 if (qsort_break_even < prev_break) {
3792 qsort_break_even = (part_right - part_left) + 1;
3796 qsort_break_even = QSORT_BREAK_EVEN;
3800 if (part_left < pc_left) {
3801 /* There are elements on the left which need more processing.
3802 Check the right as well before deciding what to do.
3804 if (pc_right < part_right) {
3805 /* We have two partitions to be sorted. Stack the biggest one
3806 and process the smallest one on the next iteration. This
3807 minimizes the stack height by insuring that any additional
3808 stack entries must come from the smallest partition which
3809 (because it is smallest) will have the fewest
3810 opportunities to generate additional stack entries.
3812 if ((part_right - pc_right) > (pc_left - part_left)) {
3813 /* stack the right partition, process the left */
3814 partition_stack[next_stack_entry].left = pc_right + 1;
3815 partition_stack[next_stack_entry].right = part_right;
3816 #ifdef QSORT_ORDER_GUESS
3817 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3819 part_right = pc_left - 1;
3821 /* stack the left partition, process the right */
3822 partition_stack[next_stack_entry].left = part_left;
3823 partition_stack[next_stack_entry].right = pc_left - 1;
3824 #ifdef QSORT_ORDER_GUESS
3825 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3827 part_left = pc_right + 1;
3829 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3832 /* The elements on the left are the only remaining elements
3833 that need sorting, arrange for them to be processed as the
3836 part_right = pc_left - 1;
3838 } else if (pc_right < part_right) {
3839 /* There is only one chunk on the right to be sorted, make it
3840 the new partition and loop back around.
3842 part_left = pc_right + 1;
3844 /* This whole partition wound up in the pivot chunk, so
3845 we need to get a new partition off the stack.
3847 if (next_stack_entry == 0) {
3848 /* the stack is empty - we are done */
3852 part_left = partition_stack[next_stack_entry].left;
3853 part_right = partition_stack[next_stack_entry].right;
3854 #ifdef QSORT_ORDER_GUESS
3855 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3859 /* This partition is too small to fool with qsort complexity, just
3860 do an ordinary insertion sort to minimize overhead.
3863 /* Assume 1st element is in right place already, and start checking
3864 at 2nd element to see where it should be inserted.
3866 for (i = part_left + 1; i <= part_right; ++i) {
3868 /* Scan (backwards - just in case 'i' is already in right place)
3869 through the elements already sorted to see if the ith element
3870 belongs ahead of one of them.
3872 for (j = i - 1; j >= part_left; --j) {
3873 if (qsort_cmp(i, j) >= 0) {
3874 /* i belongs right after j
3881 /* Looks like we really need to move some things
3885 for (k = i - 1; k >= j; --k)
3886 array[k + 1] = array[k];
3891 /* That partition is now sorted, grab the next one, or get out
3892 of the loop if there aren't any more.
3895 if (next_stack_entry == 0) {
3896 /* the stack is empty - we are done */
3900 part_left = partition_stack[next_stack_entry].left;
3901 part_right = partition_stack[next_stack_entry].right;
3902 #ifdef QSORT_ORDER_GUESS
3903 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3908 /* Believe it or not, the array is sorted at this point! */