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 warner(WARN_UNSAFE, SvPVX(err));
1263 sv_setpv(ERRSV, message);
1266 message = SvPVx(ERRSV, PL_na);
1268 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1276 if (cxix < cxstack_ix)
1279 POPBLOCK(cx,PL_curpm);
1280 if (CxTYPE(cx) != CXt_EVAL) {
1281 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1286 if (gimme == G_SCALAR)
1287 *++newsp = &PL_sv_undef;
1288 PL_stack_sp = newsp;
1292 if (optype == OP_REQUIRE) {
1293 char* msg = SvPVx(ERRSV, PL_na);
1294 DIE("%s", *msg ? msg : "Compilation failed in require");
1296 return pop_return();
1300 message = SvPVx(ERRSV, PL_na);
1301 PerlIO_printf(PerlIO_stderr(), "%s",message);
1302 PerlIO_flush(PerlIO_stderr());
1311 if (SvTRUE(left) != SvTRUE(right))
1323 RETURNOP(cLOGOP->op_other);
1332 RETURNOP(cLOGOP->op_other);
1338 register I32 cxix = dopoptosub(cxstack_ix);
1339 register PERL_CONTEXT *cx;
1340 register PERL_CONTEXT *ccstack = cxstack;
1341 PERL_SI *top_si = PL_curstackinfo;
1352 /* we may be in a higher stacklevel, so dig down deeper */
1353 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1354 top_si = top_si->si_prev;
1355 ccstack = top_si->si_cxstack;
1356 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1359 if (GIMME != G_ARRAY)
1363 if (PL_DBsub && cxix >= 0 &&
1364 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1368 cxix = dopoptosub_at(ccstack, cxix - 1);
1371 cx = &ccstack[cxix];
1372 if (CxTYPE(cx) == CXt_SUB) {
1373 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1374 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1375 field below is defined for any cx. */
1376 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1377 cx = &ccstack[dbcxix];
1380 if (GIMME != G_ARRAY) {
1381 hv = cx->blk_oldcop->cop_stash;
1383 PUSHs(&PL_sv_undef);
1386 sv_setpv(TARG, HvNAME(hv));
1392 hv = cx->blk_oldcop->cop_stash;
1394 PUSHs(&PL_sv_undef);
1396 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1397 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1398 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1401 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1403 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1404 PUSHs(sv_2mortal(sv));
1405 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1408 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1409 PUSHs(sv_2mortal(newSViv(0)));
1411 gimme = (I32)cx->blk_gimme;
1412 if (gimme == G_VOID)
1413 PUSHs(&PL_sv_undef);
1415 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1416 if (CxTYPE(cx) == CXt_EVAL) {
1417 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1418 PUSHs(cx->blk_eval.cur_text);
1421 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1422 /* Require, put the name. */
1423 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1427 else if (CxTYPE(cx) == CXt_SUB &&
1428 cx->blk_sub.hasargs &&
1429 PL_curcop->cop_stash == PL_debstash)
1431 AV *ary = cx->blk_sub.argarray;
1432 int off = AvARRAY(ary) - AvALLOC(ary);
1436 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1439 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1442 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1443 av_extend(PL_dbargs, AvFILLp(ary) + off);
1444 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1445 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1451 sortcv(SV *a, SV *b)
1454 I32 oldsaveix = PL_savestack_ix;
1455 I32 oldscopeix = PL_scopestack_ix;
1457 GvSV(PL_firstgv) = a;
1458 GvSV(PL_secondgv) = b;
1459 PL_stack_sp = PL_stack_base;
1462 if (PL_stack_sp != PL_stack_base + 1)
1463 croak("Sort subroutine didn't return single value");
1464 if (!SvNIOKp(*PL_stack_sp))
1465 croak("Sort subroutine didn't return a numeric value");
1466 result = SvIV(*PL_stack_sp);
1467 while (PL_scopestack_ix > oldscopeix) {
1470 leave_scope(oldsaveix);
1483 sv_reset(tmps, PL_curcop->cop_stash);
1495 PL_curcop = (COP*)PL_op;
1496 TAINT_NOT; /* Each statement is presumed innocent */
1497 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1500 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1504 register PERL_CONTEXT *cx;
1505 I32 gimme = G_ARRAY;
1512 DIE("No DB::DB routine defined");
1514 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1526 push_return(PL_op->op_next);
1527 PUSHBLOCK(cx, CXt_SUB, SP);
1530 (void)SvREFCNT_inc(cv);
1531 SAVESPTR(PL_curpad);
1532 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1533 RETURNOP(CvSTART(cv));
1547 register PERL_CONTEXT *cx;
1548 I32 gimme = GIMME_V;
1555 if (PL_op->op_flags & OPf_SPECIAL)
1556 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1558 #endif /* USE_THREADS */
1559 if (PL_op->op_targ) {
1560 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1565 (void)save_scalar(gv);
1566 svp = &GvSV(gv); /* symbol table variable */
1571 PUSHBLOCK(cx, CXt_LOOP, SP);
1572 PUSHLOOP(cx, svp, MARK);
1573 if (PL_op->op_flags & OPf_STACKED) {
1574 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1575 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1577 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1578 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1579 if (SvNV(sv) < IV_MIN ||
1580 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1581 croak("Range iterator outside integer range");
1582 cx->blk_loop.iterix = SvIV(sv);
1583 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1586 cx->blk_loop.iterlval = newSVsv(sv);
1590 cx->blk_loop.iterary = PL_curstack;
1591 AvFILLp(PL_curstack) = SP - PL_stack_base;
1592 cx->blk_loop.iterix = MARK - PL_stack_base;
1601 register PERL_CONTEXT *cx;
1602 I32 gimme = GIMME_V;
1608 PUSHBLOCK(cx, CXt_LOOP, SP);
1609 PUSHLOOP(cx, 0, SP);
1617 register PERL_CONTEXT *cx;
1618 struct block_loop cxloop;
1626 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1629 if (gimme == G_VOID)
1631 else if (gimme == G_SCALAR) {
1633 *++newsp = sv_mortalcopy(*SP);
1635 *++newsp = &PL_sv_undef;
1639 *++newsp = sv_mortalcopy(*++mark);
1640 TAINT_NOT; /* Each item is independent */
1646 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1647 PL_curpm = newpm; /* ... and pop $1 et al */
1659 register PERL_CONTEXT *cx;
1660 struct block_sub cxsub;
1661 bool popsub2 = FALSE;
1667 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1668 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1669 if (cxstack_ix > PL_sortcxix)
1670 dounwind(PL_sortcxix);
1671 AvARRAY(PL_curstack)[1] = *SP;
1672 PL_stack_sp = PL_stack_base + 1;
1677 cxix = dopoptosub(cxstack_ix);
1679 DIE("Can't return outside a subroutine");
1680 if (cxix < cxstack_ix)
1684 switch (CxTYPE(cx)) {
1686 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1691 if (optype == OP_REQUIRE &&
1692 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1694 /* Unassume the success we assumed earlier. */
1695 char *name = cx->blk_eval.old_name;
1696 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1697 DIE("%s did not return a true value", name);
1701 DIE("panic: return");
1705 if (gimme == G_SCALAR) {
1708 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1710 *++newsp = SvREFCNT_inc(*SP);
1715 *++newsp = sv_mortalcopy(*SP);
1718 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1720 *++newsp = sv_mortalcopy(*SP);
1722 *++newsp = &PL_sv_undef;
1724 else if (gimme == G_ARRAY) {
1725 while (++MARK <= SP) {
1726 *++newsp = (popsub2 && SvTEMP(*MARK))
1727 ? *MARK : sv_mortalcopy(*MARK);
1728 TAINT_NOT; /* Each item is independent */
1731 PL_stack_sp = newsp;
1733 /* Stack values are safe: */
1735 POPSUB2(); /* release CV and @_ ... */
1737 PL_curpm = newpm; /* ... and pop $1 et al */
1740 return pop_return();
1747 register PERL_CONTEXT *cx;
1748 struct block_loop cxloop;
1749 struct block_sub cxsub;
1756 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1758 if (PL_op->op_flags & OPf_SPECIAL) {
1759 cxix = dopoptoloop(cxstack_ix);
1761 DIE("Can't \"last\" outside a block");
1764 cxix = dopoptolabel(cPVOP->op_pv);
1766 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1768 if (cxix < cxstack_ix)
1772 switch (CxTYPE(cx)) {
1774 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1776 nextop = cxloop.last_op->op_next;
1779 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1781 nextop = pop_return();
1785 nextop = pop_return();
1792 if (gimme == G_SCALAR) {
1794 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1795 ? *SP : sv_mortalcopy(*SP);
1797 *++newsp = &PL_sv_undef;
1799 else if (gimme == G_ARRAY) {
1800 while (++MARK <= SP) {
1801 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1802 ? *MARK : sv_mortalcopy(*MARK);
1803 TAINT_NOT; /* Each item is independent */
1809 /* Stack values are safe: */
1812 POPLOOP2(); /* release loop vars ... */
1816 POPSUB2(); /* release CV and @_ ... */
1819 PL_curpm = newpm; /* ... and pop $1 et al */
1828 register PERL_CONTEXT *cx;
1831 if (PL_op->op_flags & OPf_SPECIAL) {
1832 cxix = dopoptoloop(cxstack_ix);
1834 DIE("Can't \"next\" outside a block");
1837 cxix = dopoptolabel(cPVOP->op_pv);
1839 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1841 if (cxix < cxstack_ix)
1845 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1846 LEAVE_SCOPE(oldsave);
1847 return cx->blk_loop.next_op;
1853 register PERL_CONTEXT *cx;
1856 if (PL_op->op_flags & OPf_SPECIAL) {
1857 cxix = dopoptoloop(cxstack_ix);
1859 DIE("Can't \"redo\" outside a block");
1862 cxix = dopoptolabel(cPVOP->op_pv);
1864 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1866 if (cxix < cxstack_ix)
1870 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1871 LEAVE_SCOPE(oldsave);
1872 return cx->blk_loop.redo_op;
1876 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1880 static char too_deep[] = "Target of goto is too deeply nested";
1884 if (o->op_type == OP_LEAVE ||
1885 o->op_type == OP_SCOPE ||
1886 o->op_type == OP_LEAVELOOP ||
1887 o->op_type == OP_LEAVETRY)
1889 *ops++ = cUNOPo->op_first;
1894 if (o->op_flags & OPf_KIDS) {
1896 /* First try all the kids at this level, since that's likeliest. */
1897 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1898 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1899 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1902 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1903 if (kid == PL_lastgotoprobe)
1905 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1907 (ops[-1]->op_type != OP_NEXTSTATE &&
1908 ops[-1]->op_type != OP_DBSTATE)))
1910 if (o = dofindlabel(kid, label, ops, oplimit))
1920 return pp_goto(ARGS);
1929 register PERL_CONTEXT *cx;
1930 #define GOTO_DEPTH 64
1931 OP *enterops[GOTO_DEPTH];
1933 int do_dump = (PL_op->op_type == OP_DUMP);
1936 if (PL_op->op_flags & OPf_STACKED) {
1939 /* This egregious kludge implements goto &subroutine */
1940 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1942 register PERL_CONTEXT *cx;
1943 CV* cv = (CV*)SvRV(sv);
1947 int arg_was_real = 0;
1950 if (!CvROOT(cv) && !CvXSUB(cv)) {
1955 /* autoloaded stub? */
1956 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1958 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1959 GvNAMELEN(gv), FALSE);
1960 if (autogv && (cv = GvCV(autogv)))
1962 tmpstr = sv_newmortal();
1963 gv_efullname3(tmpstr, gv, Nullch);
1964 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1966 DIE("Goto undefined subroutine");
1969 /* First do some returnish stuff. */
1970 cxix = dopoptosub(cxstack_ix);
1972 DIE("Can't goto subroutine outside a subroutine");
1973 if (cxix < cxstack_ix)
1976 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1977 DIE("Can't goto subroutine from an eval-string");
1979 if (CxTYPE(cx) == CXt_SUB &&
1980 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1981 AV* av = cx->blk_sub.argarray;
1983 items = AvFILLp(av) + 1;
1985 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1986 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1987 PL_stack_sp += items;
1989 SvREFCNT_dec(GvAV(PL_defgv));
1990 GvAV(PL_defgv) = cx->blk_sub.savearray;
1991 #endif /* USE_THREADS */
1994 AvREAL_off(av); /* so av_clear() won't clobber elts */
1998 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2002 av = (AV*)PL_curpad[0];
2004 av = GvAV(PL_defgv);
2006 items = AvFILLp(av) + 1;
2008 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2009 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2010 PL_stack_sp += items;
2012 if (CxTYPE(cx) == CXt_SUB &&
2013 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2014 SvREFCNT_dec(cx->blk_sub.cv);
2015 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2016 LEAVE_SCOPE(oldsave);
2018 /* Now do some callish stuff. */
2021 if (CvOLDSTYLE(cv)) {
2022 I32 (*fp3)_((int,int,int));
2027 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2028 items = (*fp3)(CvXSUBANY(cv).any_i32,
2029 mark - PL_stack_base + 1,
2031 SP = PL_stack_base + items;
2037 PL_stack_sp--; /* There is no cv arg. */
2038 /* Push a mark for the start of arglist */
2040 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2041 /* Pop the current context like a decent sub should */
2042 POPBLOCK(cx, PL_curpm);
2043 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2046 return pop_return();
2049 AV* padlist = CvPADLIST(cv);
2050 SV** svp = AvARRAY(padlist);
2051 if (CxTYPE(cx) == CXt_EVAL) {
2052 PL_in_eval = cx->blk_eval.old_in_eval;
2053 PL_eval_root = cx->blk_eval.old_eval_root;
2054 cx->cx_type = CXt_SUB;
2055 cx->blk_sub.hasargs = 0;
2057 cx->blk_sub.cv = cv;
2058 cx->blk_sub.olddepth = CvDEPTH(cv);
2060 if (CvDEPTH(cv) < 2)
2061 (void)SvREFCNT_inc(cv);
2062 else { /* save temporaries on recursion? */
2063 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2064 sub_crush_depth(cv);
2065 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2066 AV *newpad = newAV();
2067 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2068 I32 ix = AvFILLp((AV*)svp[1]);
2069 svp = AvARRAY(svp[0]);
2070 for ( ;ix > 0; ix--) {
2071 if (svp[ix] != &PL_sv_undef) {
2072 char *name = SvPVX(svp[ix]);
2073 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2076 /* outer lexical or anon code */
2077 av_store(newpad, ix,
2078 SvREFCNT_inc(oldpad[ix]) );
2080 else { /* our own lexical */
2082 av_store(newpad, ix, sv = (SV*)newAV());
2083 else if (*name == '%')
2084 av_store(newpad, ix, sv = (SV*)newHV());
2086 av_store(newpad, ix, sv = NEWSV(0,0));
2091 av_store(newpad, ix, sv = NEWSV(0,0));
2095 if (cx->blk_sub.hasargs) {
2098 av_store(newpad, 0, (SV*)av);
2099 AvFLAGS(av) = AVf_REIFY;
2101 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2102 AvFILLp(padlist) = CvDEPTH(cv);
2103 svp = AvARRAY(padlist);
2107 if (!cx->blk_sub.hasargs) {
2108 AV* av = (AV*)PL_curpad[0];
2110 items = AvFILLp(av) + 1;
2112 /* Mark is at the end of the stack. */
2114 Copy(AvARRAY(av), SP + 1, items, SV*);
2119 #endif /* USE_THREADS */
2120 SAVESPTR(PL_curpad);
2121 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2123 if (cx->blk_sub.hasargs)
2124 #endif /* USE_THREADS */
2126 AV* av = (AV*)PL_curpad[0];
2130 cx->blk_sub.savearray = GvAV(PL_defgv);
2131 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2132 #endif /* USE_THREADS */
2133 cx->blk_sub.argarray = av;
2136 if (items >= AvMAX(av) + 1) {
2138 if (AvARRAY(av) != ary) {
2139 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2140 SvPVX(av) = (char*)ary;
2142 if (items >= AvMAX(av) + 1) {
2143 AvMAX(av) = items - 1;
2144 Renew(ary,items+1,SV*);
2146 SvPVX(av) = (char*)ary;
2149 Copy(mark,AvARRAY(av),items,SV*);
2150 AvFILLp(av) = items - 1;
2151 /* preserve @_ nature */
2162 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2164 * We do not care about using sv to call CV;
2165 * it's for informational purposes only.
2167 SV *sv = GvSV(PL_DBsub);
2170 if (PERLDB_SUB_NN) {
2171 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2174 gv_efullname3(sv, CvGV(cv), Nullch);
2177 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2178 PUSHMARK( PL_stack_sp );
2179 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2183 RETURNOP(CvSTART(cv));
2187 label = SvPV(sv,PL_na);
2189 else if (PL_op->op_flags & OPf_SPECIAL) {
2191 DIE("goto must have label");
2194 label = cPVOP->op_pv;
2196 if (label && *label) {
2201 PL_lastgotoprobe = 0;
2203 for (ix = cxstack_ix; ix >= 0; ix--) {
2205 switch (CxTYPE(cx)) {
2207 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2210 gotoprobe = cx->blk_oldcop->op_sibling;
2216 gotoprobe = cx->blk_oldcop->op_sibling;
2218 gotoprobe = PL_main_root;
2221 if (CvDEPTH(cx->blk_sub.cv)) {
2222 gotoprobe = CvROOT(cx->blk_sub.cv);
2227 DIE("Can't \"goto\" outside a block");
2231 gotoprobe = PL_main_root;
2234 retop = dofindlabel(gotoprobe, label,
2235 enterops, enterops + GOTO_DEPTH);
2238 PL_lastgotoprobe = gotoprobe;
2241 DIE("Can't find label %s", label);
2243 /* pop unwanted frames */
2245 if (ix < cxstack_ix) {
2252 oldsave = PL_scopestack[PL_scopestack_ix];
2253 LEAVE_SCOPE(oldsave);
2256 /* push wanted frames */
2258 if (*enterops && enterops[1]) {
2260 for (ix = 1; enterops[ix]; ix++) {
2261 PL_op = enterops[ix];
2262 /* Eventually we may want to stack the needed arguments
2263 * for each op. For now, we punt on the hard ones. */
2264 if (PL_op->op_type == OP_ENTERITER)
2265 DIE("Can't \"goto\" into the middle of a foreach loop",
2267 (CALLOP->op_ppaddr)(ARGS);
2275 if (!retop) retop = PL_main_start;
2277 PL_restartop = retop;
2278 PL_do_undump = TRUE;
2282 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2283 PL_do_undump = FALSE;
2299 if (anum == 1 && VMSISH_EXIT)
2304 PUSHs(&PL_sv_undef);
2312 double value = SvNVx(GvSV(cCOP->cop_gv));
2313 register I32 match = I_32(value);
2316 if (((double)match) > value)
2317 --match; /* was fractional--truncate other way */
2319 match -= cCOP->uop.scop.scop_offset;
2322 else if (match > cCOP->uop.scop.scop_max)
2323 match = cCOP->uop.scop.scop_max;
2324 PL_op = cCOP->uop.scop.scop_next[match];
2334 PL_op = PL_op->op_next; /* can't assume anything */
2336 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2337 match -= cCOP->uop.scop.scop_offset;
2340 else if (match > cCOP->uop.scop.scop_max)
2341 match = cCOP->uop.scop.scop_max;
2342 PL_op = cCOP->uop.scop.scop_next[match];
2351 save_lines(AV *array, SV *sv)
2353 register char *s = SvPVX(sv);
2354 register char *send = SvPVX(sv) + SvCUR(sv);
2356 register I32 line = 1;
2358 while (s && s < send) {
2359 SV *tmpstr = NEWSV(85,0);
2361 sv_upgrade(tmpstr, SVt_PVMG);
2362 t = strchr(s, '\n');
2368 sv_setpvn(tmpstr, s, t - s);
2369 av_store(array, line++, tmpstr);
2384 assert(CATCH_GET == TRUE);
2385 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2389 default: /* topmost level handles it */
2398 PL_op = PL_restartop;
2411 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2412 /* sv Text to convert to OP tree. */
2413 /* startop op_free() this to undo. */
2414 /* code Short string id of the caller. */
2416 dSP; /* Make POPBLOCK work. */
2419 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2422 OP *oop = PL_op, *rop;
2423 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2429 /* switch to eval mode */
2431 if (PL_curcop == &PL_compiling) {
2432 SAVESPTR(PL_compiling.cop_stash);
2433 PL_compiling.cop_stash = PL_curstash;
2435 SAVESPTR(PL_compiling.cop_filegv);
2436 SAVEI16(PL_compiling.cop_line);
2437 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2438 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2439 PL_compiling.cop_line = 1;
2440 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2441 deleting the eval's FILEGV from the stash before gv_check() runs
2442 (i.e. before run-time proper). To work around the coredump that
2443 ensues, we always turn GvMULTI_on for any globals that were
2444 introduced within evals. See force_ident(). GSAR 96-10-12 */
2445 safestr = savepv(tmpbuf);
2446 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2448 #ifdef OP_IN_REGISTER
2456 PL_op->op_type = OP_ENTEREVAL;
2457 PL_op->op_flags = 0; /* Avoid uninit warning. */
2458 PUSHBLOCK(cx, CXt_EVAL, SP);
2459 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2460 rop = doeval(G_SCALAR, startop);
2461 POPBLOCK(cx,PL_curpm);
2464 (*startop)->op_type = OP_NULL;
2465 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2467 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2469 if (PL_curcop == &PL_compiling)
2470 PL_compiling.op_private = PL_hints;
2471 #ifdef OP_IN_REGISTER
2477 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2479 doeval(int gimme, OP** startop)
2492 /* set up a scratch pad */
2495 SAVESPTR(PL_curpad);
2496 SAVESPTR(PL_comppad);
2497 SAVESPTR(PL_comppad_name);
2498 SAVEI32(PL_comppad_name_fill);
2499 SAVEI32(PL_min_intro_pending);
2500 SAVEI32(PL_max_intro_pending);
2503 for (i = cxstack_ix - 1; i >= 0; i--) {
2504 PERL_CONTEXT *cx = &cxstack[i];
2505 if (CxTYPE(cx) == CXt_EVAL)
2507 else if (CxTYPE(cx) == CXt_SUB) {
2508 caller = cx->blk_sub.cv;
2513 SAVESPTR(PL_compcv);
2514 PL_compcv = (CV*)NEWSV(1104,0);
2515 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2516 CvUNIQUE_on(PL_compcv);
2518 CvOWNER(PL_compcv) = 0;
2519 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2520 MUTEX_INIT(CvMUTEXP(PL_compcv));
2521 #endif /* USE_THREADS */
2523 PL_comppad = newAV();
2524 av_push(PL_comppad, Nullsv);
2525 PL_curpad = AvARRAY(PL_comppad);
2526 PL_comppad_name = newAV();
2527 PL_comppad_name_fill = 0;
2528 PL_min_intro_pending = 0;
2531 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2532 PL_curpad[0] = (SV*)newAV();
2533 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2534 #endif /* USE_THREADS */
2536 comppadlist = newAV();
2537 AvREAL_off(comppadlist);
2538 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2539 av_store(comppadlist, 1, (SV*)PL_comppad);
2540 CvPADLIST(PL_compcv) = comppadlist;
2542 if (!saveop || saveop->op_type != OP_REQUIRE)
2543 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2545 SAVEFREESV(PL_compcv);
2547 /* make sure we compile in the right package */
2549 newstash = PL_curcop->cop_stash;
2550 if (PL_curstash != newstash) {
2551 SAVESPTR(PL_curstash);
2552 PL_curstash = newstash;
2554 SAVESPTR(PL_beginav);
2555 PL_beginav = newAV();
2556 SAVEFREESV(PL_beginav);
2558 /* try to compile it */
2560 PL_eval_root = Nullop;
2562 PL_curcop = &PL_compiling;
2563 PL_curcop->cop_arybase = 0;
2564 SvREFCNT_dec(PL_rs);
2565 PL_rs = newSVpv("\n", 1);
2566 if (saveop && saveop->op_flags & OPf_SPECIAL)
2570 if (yyparse() || PL_error_count || !PL_eval_root) {
2574 I32 optype = 0; /* Might be reset by POPEVAL. */
2578 op_free(PL_eval_root);
2579 PL_eval_root = Nullop;
2581 SP = PL_stack_base + POPMARK; /* pop original mark */
2583 POPBLOCK(cx,PL_curpm);
2589 if (optype == OP_REQUIRE) {
2590 char* msg = SvPVx(ERRSV, PL_na);
2591 DIE("%s", *msg ? msg : "Compilation failed in require");
2592 } else if (startop) {
2593 char* msg = SvPVx(ERRSV, PL_na);
2595 POPBLOCK(cx,PL_curpm);
2597 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2599 SvREFCNT_dec(PL_rs);
2600 PL_rs = SvREFCNT_inc(PL_nrs);
2602 MUTEX_LOCK(&PL_eval_mutex);
2604 COND_SIGNAL(&PL_eval_cond);
2605 MUTEX_UNLOCK(&PL_eval_mutex);
2606 #endif /* USE_THREADS */
2609 SvREFCNT_dec(PL_rs);
2610 PL_rs = SvREFCNT_inc(PL_nrs);
2611 PL_compiling.cop_line = 0;
2613 *startop = PL_eval_root;
2614 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2615 CvOUTSIDE(PL_compcv) = Nullcv;
2617 SAVEFREEOP(PL_eval_root);
2619 scalarvoid(PL_eval_root);
2620 else if (gimme & G_ARRAY)
2623 scalar(PL_eval_root);
2625 DEBUG_x(dump_eval());
2627 /* Register with debugger: */
2628 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2629 CV *cv = perl_get_cv("DB::postponed", FALSE);
2633 XPUSHs((SV*)PL_compiling.cop_filegv);
2635 perl_call_sv((SV*)cv, G_DISCARD);
2639 /* compiled okay, so do it */
2641 CvDEPTH(PL_compcv) = 1;
2642 SP = PL_stack_base + POPMARK; /* pop original mark */
2643 PL_op = saveop; /* The caller may need it. */
2645 MUTEX_LOCK(&PL_eval_mutex);
2647 COND_SIGNAL(&PL_eval_cond);
2648 MUTEX_UNLOCK(&PL_eval_mutex);
2649 #endif /* USE_THREADS */
2651 RETURNOP(PL_eval_start);
2657 register PERL_CONTEXT *cx;
2662 SV *namesv = Nullsv;
2664 I32 gimme = G_SCALAR;
2665 PerlIO *tryrsfp = 0;
2668 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2669 SET_NUMERIC_STANDARD();
2670 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2671 DIE("Perl %s required--this is only version %s, stopped",
2672 SvPV(sv,PL_na),PL_patchlevel);
2675 name = SvPV(sv, len);
2676 if (!(name && len > 0 && *name))
2677 DIE("Null filename used");
2678 TAINT_PROPER("require");
2679 if (PL_op->op_type == OP_REQUIRE &&
2680 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2681 *svp != &PL_sv_undef)
2684 /* prepare to compile file */
2689 (name[1] == '.' && name[2] == '/')))
2691 || (name[0] && name[1] == ':')
2694 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2697 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2698 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2703 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2706 AV *ar = GvAVn(PL_incgv);
2710 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2713 namesv = NEWSV(806, 0);
2714 for (i = 0; i <= AvFILL(ar); i++) {
2715 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2718 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2720 sv_setpv(namesv, unixdir);
2721 sv_catpv(namesv, unixname);
2723 sv_setpvf(namesv, "%s/%s", dir, name);
2725 TAINT_PROPER("require");
2726 tryname = SvPVX(namesv);
2727 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2729 if (tryname[0] == '.' && tryname[1] == '/')
2736 SAVESPTR(PL_compiling.cop_filegv);
2737 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2738 SvREFCNT_dec(namesv);
2740 if (PL_op->op_type == OP_REQUIRE) {
2741 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2742 SV *dirmsgsv = NEWSV(0, 0);
2743 AV *ar = GvAVn(PL_incgv);
2745 if (instr(SvPVX(msg), ".h "))
2746 sv_catpv(msg, " (change .h to .ph maybe?)");
2747 if (instr(SvPVX(msg), ".ph "))
2748 sv_catpv(msg, " (did you run h2ph?)");
2749 sv_catpv(msg, " (@INC contains:");
2750 for (i = 0; i <= AvFILL(ar); i++) {
2751 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2752 sv_setpvf(dirmsgsv, " %s", dir);
2753 sv_catsv(msg, dirmsgsv);
2755 sv_catpvn(msg, ")", 1);
2756 SvREFCNT_dec(dirmsgsv);
2763 SETERRNO(0, SS$_NORMAL);
2765 /* Assume success here to prevent recursive requirement. */
2766 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2767 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2771 lex_start(sv_2mortal(newSVpv("",0)));
2772 SAVEGENERICSV(PL_rsfp_filters);
2773 PL_rsfp_filters = Nullav;
2776 name = savepv(name);
2780 SAVEPPTR(PL_compiling.cop_warnings);
2781 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2784 /* switch to eval mode */
2786 push_return(PL_op->op_next);
2787 PUSHBLOCK(cx, CXt_EVAL, SP);
2788 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2790 SAVEI16(PL_compiling.cop_line);
2791 PL_compiling.cop_line = 0;
2795 MUTEX_LOCK(&PL_eval_mutex);
2796 if (PL_eval_owner && PL_eval_owner != thr)
2797 while (PL_eval_owner)
2798 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2799 PL_eval_owner = thr;
2800 MUTEX_UNLOCK(&PL_eval_mutex);
2801 #endif /* USE_THREADS */
2802 return DOCATCH(doeval(G_SCALAR, NULL));
2807 return pp_require(ARGS);
2813 register PERL_CONTEXT *cx;
2815 I32 gimme = GIMME_V, was = PL_sub_generation;
2816 char tmpbuf[TYPE_DIGITS(long) + 12];
2821 if (!SvPV(sv,len) || !len)
2823 TAINT_PROPER("eval");
2829 /* switch to eval mode */
2831 SAVESPTR(PL_compiling.cop_filegv);
2832 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2833 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2834 PL_compiling.cop_line = 1;
2835 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2836 deleting the eval's FILEGV from the stash before gv_check() runs
2837 (i.e. before run-time proper). To work around the coredump that
2838 ensues, we always turn GvMULTI_on for any globals that were
2839 introduced within evals. See force_ident(). GSAR 96-10-12 */
2840 safestr = savepv(tmpbuf);
2841 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2843 PL_hints = PL_op->op_targ;
2844 SAVEPPTR(PL_compiling.cop_warnings);
2845 if (PL_compiling.cop_warnings != WARN_ALL
2846 && PL_compiling.cop_warnings != WARN_NONE){
2847 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2848 SAVEFREESV(PL_compiling.cop_warnings) ;
2851 push_return(PL_op->op_next);
2852 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2853 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2855 /* prepare to compile string */
2857 if (PERLDB_LINE && PL_curstash != PL_debstash)
2858 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2861 MUTEX_LOCK(&PL_eval_mutex);
2862 if (PL_eval_owner && PL_eval_owner != thr)
2863 while (PL_eval_owner)
2864 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2865 PL_eval_owner = thr;
2866 MUTEX_UNLOCK(&PL_eval_mutex);
2867 #endif /* USE_THREADS */
2868 ret = doeval(gimme, NULL);
2869 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2870 && ret != PL_op->op_next) { /* Successive compilation. */
2871 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2873 return DOCATCH(ret);
2883 register PERL_CONTEXT *cx;
2885 U8 save_flags = PL_op -> op_flags;
2890 retop = pop_return();
2893 if (gimme == G_VOID)
2895 else if (gimme == G_SCALAR) {
2898 if (SvFLAGS(TOPs) & SVs_TEMP)
2901 *MARK = sv_mortalcopy(TOPs);
2905 *MARK = &PL_sv_undef;
2909 /* in case LEAVE wipes old return values */
2910 for (mark = newsp + 1; mark <= SP; mark++) {
2911 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2912 *mark = sv_mortalcopy(*mark);
2913 TAINT_NOT; /* Each item is independent */
2917 PL_curpm = newpm; /* Don't pop $1 et al till now */
2920 * Closures mentioned at top level of eval cannot be referenced
2921 * again, and their presence indirectly causes a memory leak.
2922 * (Note that the fact that compcv and friends are still set here
2923 * is, AFAIK, an accident.) --Chip
2925 if (AvFILLp(PL_comppad_name) >= 0) {
2926 SV **svp = AvARRAY(PL_comppad_name);
2928 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2930 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2932 svp[ix] = &PL_sv_undef;
2936 SvREFCNT_dec(CvOUTSIDE(sv));
2937 CvOUTSIDE(sv) = Nullcv;
2950 assert(CvDEPTH(PL_compcv) == 1);
2952 CvDEPTH(PL_compcv) = 0;
2955 if (optype == OP_REQUIRE &&
2956 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2958 /* Unassume the success we assumed earlier. */
2959 char *name = cx->blk_eval.old_name;
2960 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2961 retop = die("%s did not return a true value", name);
2962 /* die_where() did LEAVE, or we won't be here */
2966 if (!(save_flags & OPf_SPECIAL))
2976 register PERL_CONTEXT *cx;
2977 I32 gimme = GIMME_V;
2982 push_return(cLOGOP->op_other->op_next);
2983 PUSHBLOCK(cx, CXt_EVAL, SP);
2985 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2990 return DOCATCH(PL_op->op_next);
3000 register PERL_CONTEXT *cx;
3008 if (gimme == G_VOID)
3010 else if (gimme == G_SCALAR) {
3013 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3016 *MARK = sv_mortalcopy(TOPs);
3020 *MARK = &PL_sv_undef;
3025 /* in case LEAVE wipes old return values */
3026 for (mark = newsp + 1; mark <= SP; mark++) {
3027 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3028 *mark = sv_mortalcopy(*mark);
3029 TAINT_NOT; /* Each item is independent */
3033 PL_curpm = newpm; /* Don't pop $1 et al till now */
3044 register char *s = SvPV_force(sv, len);
3045 register char *send = s + len;
3046 register char *base;
3047 register I32 skipspaces = 0;
3050 bool postspace = FALSE;
3058 croak("Null picture in formline");
3060 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3065 *fpc++ = FF_LINEMARK;
3066 noblank = repeat = FALSE;
3084 case ' ': case '\t':
3095 *fpc++ = FF_LITERAL;
3103 *fpc++ = skipspaces;
3107 *fpc++ = FF_NEWLINE;
3111 arg = fpc - linepc + 1;
3118 *fpc++ = FF_LINEMARK;
3119 noblank = repeat = FALSE;
3128 ischop = s[-1] == '^';
3134 arg = (s - base) - 1;
3136 *fpc++ = FF_LITERAL;
3145 *fpc++ = FF_LINEGLOB;
3147 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3148 arg = ischop ? 512 : 0;
3158 arg |= 256 + (s - f);
3160 *fpc++ = s - base; /* fieldsize for FETCH */
3161 *fpc++ = FF_DECIMAL;
3166 bool ismore = FALSE;
3169 while (*++s == '>') ;
3170 prespace = FF_SPACE;
3172 else if (*s == '|') {
3173 while (*++s == '|') ;
3174 prespace = FF_HALFSPACE;
3179 while (*++s == '<') ;
3182 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3186 *fpc++ = s - base; /* fieldsize for FETCH */
3188 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3206 { /* need to jump to the next word */
3208 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3209 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3210 s = SvPVX(sv) + SvCUR(sv) + z;
3212 Copy(fops, s, arg, U16);
3214 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3219 * The rest of this file was derived from source code contributed
3222 * NOTE: this code was derived from Tom Horsley's qsort replacement
3223 * and should not be confused with the original code.
3226 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3228 Permission granted to distribute under the same terms as perl which are
3231 This program is free software; you can redistribute it and/or modify
3232 it under the terms of either:
3234 a) the GNU General Public License as published by the Free
3235 Software Foundation; either version 1, or (at your option) any
3238 b) the "Artistic License" which comes with this Kit.
3240 Details on the perl license can be found in the perl source code which
3241 may be located via the www.perl.com web page.
3243 This is the most wonderfulest possible qsort I can come up with (and
3244 still be mostly portable) My (limited) tests indicate it consistently
3245 does about 20% fewer calls to compare than does the qsort in the Visual
3246 C++ library, other vendors may vary.
3248 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3249 others I invented myself (or more likely re-invented since they seemed
3250 pretty obvious once I watched the algorithm operate for a while).
3252 Most of this code was written while watching the Marlins sweep the Giants
3253 in the 1997 National League Playoffs - no Braves fans allowed to use this
3254 code (just kidding :-).
3256 I realize that if I wanted to be true to the perl tradition, the only
3257 comment in this file would be something like:
3259 ...they shuffled back towards the rear of the line. 'No, not at the
3260 rear!' the slave-driver shouted. 'Three files up. And stay there...
3262 However, I really needed to violate that tradition just so I could keep
3263 track of what happens myself, not to mention some poor fool trying to
3264 understand this years from now :-).
3267 /* ********************************************************** Configuration */
3269 #ifndef QSORT_ORDER_GUESS
3270 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3273 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3274 future processing - a good max upper bound is log base 2 of memory size
3275 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3276 safely be smaller than that since the program is taking up some space and
3277 most operating systems only let you grab some subset of contiguous
3278 memory (not to mention that you are normally sorting data larger than
3279 1 byte element size :-).
3281 #ifndef QSORT_MAX_STACK
3282 #define QSORT_MAX_STACK 32
3285 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3286 Anything bigger and we use qsort. If you make this too small, the qsort
3287 will probably break (or become less efficient), because it doesn't expect
3288 the middle element of a partition to be the same as the right or left -
3289 you have been warned).
3291 #ifndef QSORT_BREAK_EVEN
3292 #define QSORT_BREAK_EVEN 6
3295 /* ************************************************************* Data Types */
3297 /* hold left and right index values of a partition waiting to be sorted (the
3298 partition includes both left and right - right is NOT one past the end or
3299 anything like that).
3301 struct partition_stack_entry {
3304 #ifdef QSORT_ORDER_GUESS
3305 int qsort_break_even;
3309 /* ******************************************************* Shorthand Macros */
3311 /* Note that these macros will be used from inside the qsort function where
3312 we happen to know that the variable 'elt_size' contains the size of an
3313 array element and the variable 'temp' points to enough space to hold a
3314 temp element and the variable 'array' points to the array being sorted
3315 and 'compare' is the pointer to the compare routine.
3317 Also note that there are very many highly architecture specific ways
3318 these might be sped up, but this is simply the most generally portable
3319 code I could think of.
3322 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3325 #define qsort_cmp(elt1, elt2) \
3326 ((this->*compare)(array[elt1], array[elt2]))
3328 #define qsort_cmp(elt1, elt2) \
3329 ((*compare)(array[elt1], array[elt2]))
3332 #ifdef QSORT_ORDER_GUESS
3333 #define QSORT_NOTICE_SWAP swapped++;
3335 #define QSORT_NOTICE_SWAP
3338 /* swaps contents of array elements elt1, elt2.
3340 #define qsort_swap(elt1, elt2) \
3343 temp = array[elt1]; \
3344 array[elt1] = array[elt2]; \
3345 array[elt2] = temp; \
3348 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3349 elt3 and elt3 gets elt1.
3351 #define qsort_rotate(elt1, elt2, elt3) \
3354 temp = array[elt1]; \
3355 array[elt1] = array[elt2]; \
3356 array[elt2] = array[elt3]; \
3357 array[elt3] = temp; \
3360 /* ************************************************************ Debug stuff */
3367 return; /* good place to set a breakpoint */
3370 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3373 doqsort_all_asserts(
3377 int (*compare)(const void * elt1, const void * elt2),
3378 int pc_left, int pc_right, int u_left, int u_right)
3382 qsort_assert(pc_left <= pc_right);
3383 qsort_assert(u_right < pc_left);
3384 qsort_assert(pc_right < u_left);
3385 for (i = u_right + 1; i < pc_left; ++i) {
3386 qsort_assert(qsort_cmp(i, pc_left) < 0);
3388 for (i = pc_left; i < pc_right; ++i) {
3389 qsort_assert(qsort_cmp(i, pc_right) == 0);
3391 for (i = pc_right + 1; i < u_left; ++i) {
3392 qsort_assert(qsort_cmp(pc_right, i) < 0);
3396 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3397 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3398 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3402 #define qsort_assert(t) ((void)0)
3404 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3408 /* ****************************************************************** qsort */
3412 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3417 I32 (*compare)(SV *a, SV *b))
3422 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3423 int next_stack_entry = 0;
3427 #ifdef QSORT_ORDER_GUESS
3428 int qsort_break_even;
3432 /* Make sure we actually have work to do.
3434 if (num_elts <= 1) {
3438 /* Setup the initial partition definition and fall into the sorting loop
3441 part_right = (int)(num_elts - 1);
3442 #ifdef QSORT_ORDER_GUESS
3443 qsort_break_even = QSORT_BREAK_EVEN;
3445 #define qsort_break_even QSORT_BREAK_EVEN
3448 if ((part_right - part_left) >= qsort_break_even) {
3449 /* OK, this is gonna get hairy, so lets try to document all the
3450 concepts and abbreviations and variables and what they keep
3453 pc: pivot chunk - the set of array elements we accumulate in the
3454 middle of the partition, all equal in value to the original
3455 pivot element selected. The pc is defined by:
3457 pc_left - the leftmost array index of the pc
3458 pc_right - the rightmost array index of the pc
3460 we start with pc_left == pc_right and only one element
3461 in the pivot chunk (but it can grow during the scan).
3463 u: uncompared elements - the set of elements in the partition
3464 we have not yet compared to the pivot value. There are two
3465 uncompared sets during the scan - one to the left of the pc
3466 and one to the right.
3468 u_right - the rightmost index of the left side's uncompared set
3469 u_left - the leftmost index of the right side's uncompared set
3471 The leftmost index of the left sides's uncompared set
3472 doesn't need its own variable because it is always defined
3473 by the leftmost edge of the whole partition (part_left). The
3474 same goes for the rightmost edge of the right partition
3477 We know there are no uncompared elements on the left once we
3478 get u_right < part_left and no uncompared elements on the
3479 right once u_left > part_right. When both these conditions
3480 are met, we have completed the scan of the partition.
3482 Any elements which are between the pivot chunk and the
3483 uncompared elements should be less than the pivot value on
3484 the left side and greater than the pivot value on the right
3485 side (in fact, the goal of the whole algorithm is to arrange
3486 for that to be true and make the groups of less-than and
3487 greater-then elements into new partitions to sort again).
3489 As you marvel at the complexity of the code and wonder why it
3490 has to be so confusing. Consider some of the things this level
3491 of confusion brings:
3493 Once I do a compare, I squeeze every ounce of juice out of it. I
3494 never do compare calls I don't have to do, and I certainly never
3497 I also never swap any elements unless I can prove there is a
3498 good reason. Many sort algorithms will swap a known value with
3499 an uncompared value just to get things in the right place (or
3500 avoid complexity :-), but that uncompared value, once it gets
3501 compared, may then have to be swapped again. A lot of the
3502 complexity of this code is due to the fact that it never swaps
3503 anything except compared values, and it only swaps them when the
3504 compare shows they are out of position.
3506 int pc_left, pc_right;
3507 int u_right, u_left;
3511 pc_left = ((part_left + part_right) / 2);
3513 u_right = pc_left - 1;
3514 u_left = pc_right + 1;
3516 /* Qsort works best when the pivot value is also the median value
3517 in the partition (unfortunately you can't find the median value
3518 without first sorting :-), so to give the algorithm a helping
3519 hand, we pick 3 elements and sort them and use the median value
3520 of that tiny set as the pivot value.
3522 Some versions of qsort like to use the left middle and right as
3523 the 3 elements to sort so they can insure the ends of the
3524 partition will contain values which will stop the scan in the
3525 compare loop, but when you have to call an arbitrarily complex
3526 routine to do a compare, its really better to just keep track of
3527 array index values to know when you hit the edge of the
3528 partition and avoid the extra compare. An even better reason to
3529 avoid using a compare call is the fact that you can drop off the
3530 edge of the array if someone foolishly provides you with an
3531 unstable compare function that doesn't always provide consistent
3534 So, since it is simpler for us to compare the three adjacent
3535 elements in the middle of the partition, those are the ones we
3536 pick here (conveniently pointed at by u_right, pc_left, and
3537 u_left). The values of the left, center, and right elements
3538 are refered to as l c and r in the following comments.
3541 #ifdef QSORT_ORDER_GUESS
3544 s = qsort_cmp(u_right, pc_left);
3547 s = qsort_cmp(pc_left, u_left);
3548 /* if l < c, c < r - already in order - nothing to do */
3550 /* l < c, c == r - already in order, pc grows */
3552 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3554 /* l < c, c > r - need to know more */
3555 s = qsort_cmp(u_right, u_left);
3557 /* l < c, c > r, l < r - swap c & r to get ordered */
3558 qsort_swap(pc_left, u_left);
3559 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3560 } else if (s == 0) {
3561 /* l < c, c > r, l == r - swap c&r, grow pc */
3562 qsort_swap(pc_left, u_left);
3564 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3566 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3567 qsort_rotate(pc_left, u_right, u_left);
3568 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3571 } else if (s == 0) {
3573 s = qsort_cmp(pc_left, u_left);
3575 /* l == c, c < r - already in order, grow pc */
3577 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3578 } else if (s == 0) {
3579 /* l == c, c == r - already in order, grow pc both ways */
3582 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3584 /* l == c, c > r - swap l & r, grow pc */
3585 qsort_swap(u_right, u_left);
3587 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3591 s = qsort_cmp(pc_left, u_left);
3593 /* l > c, c < r - need to know more */
3594 s = qsort_cmp(u_right, u_left);
3596 /* l > c, c < r, l < r - swap l & c to get ordered */
3597 qsort_swap(u_right, pc_left);
3598 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3599 } else if (s == 0) {
3600 /* l > c, c < r, l == r - swap l & c, grow pc */
3601 qsort_swap(u_right, pc_left);
3603 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3605 /* l > c, c < r, l > r - rotate lcr into crl to order */
3606 qsort_rotate(u_right, pc_left, u_left);
3607 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3609 } else if (s == 0) {
3610 /* l > c, c == r - swap ends, grow pc */
3611 qsort_swap(u_right, u_left);
3613 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3615 /* l > c, c > r - swap ends to get in order */
3616 qsort_swap(u_right, u_left);
3617 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3620 /* We now know the 3 middle elements have been compared and
3621 arranged in the desired order, so we can shrink the uncompared
3626 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3628 /* The above massive nested if was the simple part :-). We now have
3629 the middle 3 elements ordered and we need to scan through the
3630 uncompared sets on either side, swapping elements that are on
3631 the wrong side or simply shuffling equal elements around to get
3632 all equal elements into the pivot chunk.
3636 int still_work_on_left;
3637 int still_work_on_right;
3639 /* Scan the uncompared values on the left. If I find a value
3640 equal to the pivot value, move it over so it is adjacent to
3641 the pivot chunk and expand the pivot chunk. If I find a value
3642 less than the pivot value, then just leave it - its already
3643 on the correct side of the partition. If I find a greater
3644 value, then stop the scan.
3646 while (still_work_on_left = (u_right >= part_left)) {
3647 s = qsort_cmp(u_right, pc_left);
3650 } else if (s == 0) {
3652 if (pc_left != u_right) {
3653 qsort_swap(u_right, pc_left);
3659 qsort_assert(u_right < pc_left);
3660 qsort_assert(pc_left <= pc_right);
3661 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3662 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3665 /* Do a mirror image scan of uncompared values on the right
3667 while (still_work_on_right = (u_left <= part_right)) {
3668 s = qsort_cmp(pc_right, u_left);
3671 } else if (s == 0) {
3673 if (pc_right != u_left) {
3674 qsort_swap(pc_right, u_left);
3680 qsort_assert(u_left > pc_right);
3681 qsort_assert(pc_left <= pc_right);
3682 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3683 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3686 if (still_work_on_left) {
3687 /* I know I have a value on the left side which needs to be
3688 on the right side, but I need to know more to decide
3689 exactly the best thing to do with it.
3691 if (still_work_on_right) {
3692 /* I know I have values on both side which are out of
3693 position. This is a big win because I kill two birds
3694 with one swap (so to speak). I can advance the
3695 uncompared pointers on both sides after swapping both
3696 of them into the right place.
3698 qsort_swap(u_right, u_left);
3701 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3703 /* I have an out of position value on the left, but the
3704 right is fully scanned, so I "slide" the pivot chunk
3705 and any less-than values left one to make room for the
3706 greater value over on the right. If the out of position
3707 value is immediately adjacent to the pivot chunk (there
3708 are no less-than values), I can do that with a swap,
3709 otherwise, I have to rotate one of the less than values
3710 into the former position of the out of position value
3711 and the right end of the pivot chunk into the left end
3715 if (pc_left == u_right) {
3716 qsort_swap(u_right, pc_right);
3717 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3719 qsort_rotate(u_right, pc_left, pc_right);
3720 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3725 } else if (still_work_on_right) {
3726 /* Mirror image of complex case above: I have an out of
3727 position value on the right, but the left is fully
3728 scanned, so I need to shuffle things around to make room
3729 for the right value on the left.
3732 if (pc_right == u_left) {
3733 qsort_swap(u_left, pc_left);
3734 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3736 qsort_rotate(pc_right, pc_left, u_left);
3737 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3742 /* No more scanning required on either side of partition,
3743 break out of loop and figure out next set of partitions
3749 /* The elements in the pivot chunk are now in the right place. They
3750 will never move or be compared again. All I have to do is decide
3751 what to do with the stuff to the left and right of the pivot
3754 Notes on the QSORT_ORDER_GUESS ifdef code:
3756 1. If I just built these partitions without swapping any (or
3757 very many) elements, there is a chance that the elements are
3758 already ordered properly (being properly ordered will
3759 certainly result in no swapping, but the converse can't be
3762 2. A (properly written) insertion sort will run faster on
3763 already ordered data than qsort will.
3765 3. Perhaps there is some way to make a good guess about
3766 switching to an insertion sort earlier than partition size 6
3767 (for instance - we could save the partition size on the stack
3768 and increase the size each time we find we didn't swap, thus
3769 switching to insertion sort earlier for partitions with a
3770 history of not swapping).
3772 4. Naturally, if I just switch right away, it will make
3773 artificial benchmarks with pure ascending (or descending)
3774 data look really good, but is that a good reason in general?
3778 #ifdef QSORT_ORDER_GUESS
3780 #if QSORT_ORDER_GUESS == 1
3781 qsort_break_even = (part_right - part_left) + 1;
3783 #if QSORT_ORDER_GUESS == 2
3784 qsort_break_even *= 2;
3786 #if QSORT_ORDER_GUESS == 3
3787 int prev_break = qsort_break_even;
3788 qsort_break_even *= qsort_break_even;
3789 if (qsort_break_even < prev_break) {
3790 qsort_break_even = (part_right - part_left) + 1;
3794 qsort_break_even = QSORT_BREAK_EVEN;
3798 if (part_left < pc_left) {
3799 /* There are elements on the left which need more processing.
3800 Check the right as well before deciding what to do.
3802 if (pc_right < part_right) {
3803 /* We have two partitions to be sorted. Stack the biggest one
3804 and process the smallest one on the next iteration. This
3805 minimizes the stack height by insuring that any additional
3806 stack entries must come from the smallest partition which
3807 (because it is smallest) will have the fewest
3808 opportunities to generate additional stack entries.
3810 if ((part_right - pc_right) > (pc_left - part_left)) {
3811 /* stack the right partition, process the left */
3812 partition_stack[next_stack_entry].left = pc_right + 1;
3813 partition_stack[next_stack_entry].right = part_right;
3814 #ifdef QSORT_ORDER_GUESS
3815 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3817 part_right = pc_left - 1;
3819 /* stack the left partition, process the right */
3820 partition_stack[next_stack_entry].left = part_left;
3821 partition_stack[next_stack_entry].right = pc_left - 1;
3822 #ifdef QSORT_ORDER_GUESS
3823 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3825 part_left = pc_right + 1;
3827 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3830 /* The elements on the left are the only remaining elements
3831 that need sorting, arrange for them to be processed as the
3834 part_right = pc_left - 1;
3836 } else if (pc_right < part_right) {
3837 /* There is only one chunk on the right to be sorted, make it
3838 the new partition and loop back around.
3840 part_left = pc_right + 1;
3842 /* This whole partition wound up in the pivot chunk, so
3843 we need to get a new partition off the stack.
3845 if (next_stack_entry == 0) {
3846 /* the stack is empty - we are done */
3850 part_left = partition_stack[next_stack_entry].left;
3851 part_right = partition_stack[next_stack_entry].right;
3852 #ifdef QSORT_ORDER_GUESS
3853 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3857 /* This partition is too small to fool with qsort complexity, just
3858 do an ordinary insertion sort to minimize overhead.
3861 /* Assume 1st element is in right place already, and start checking
3862 at 2nd element to see where it should be inserted.
3864 for (i = part_left + 1; i <= part_right; ++i) {
3866 /* Scan (backwards - just in case 'i' is already in right place)
3867 through the elements already sorted to see if the ith element
3868 belongs ahead of one of them.
3870 for (j = i - 1; j >= part_left; --j) {
3871 if (qsort_cmp(i, j) >= 0) {
3872 /* i belongs right after j
3879 /* Looks like we really need to move some things
3883 for (k = i - 1; k >= j; --k)
3884 array[k + 1] = array[k];
3889 /* That partition is now sorted, grab the next one, or get out
3890 of the loop if there aren't any more.
3893 if (next_stack_entry == 0) {
3894 /* the stack is empty - we are done */
3898 part_left = partition_stack[next_stack_entry].left;
3899 part_right = partition_stack[next_stack_entry].right;
3900 #ifdef QSORT_ORDER_GUESS
3901 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3906 /* Believe it or not, the array is sorted at this point! */