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, cx->sb_targ, NULL,
168 ((cx->sb_rflags & REXEC_COPY_STR)
169 ? 0 : REXEC_COPY_STR)))
171 SV *targ = cx->sb_targ;
172 sv_catpvn(dstr, s, cx->sb_strend - s);
174 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
176 (void)SvOOK_off(targ);
177 Safefree(SvPVX(targ));
178 SvPVX(targ) = SvPVX(dstr);
179 SvCUR_set(targ, SvCUR(dstr));
180 SvLEN_set(targ, SvLEN(dstr));
184 TAINT_IF(cx->sb_rxtainted & 1);
185 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
187 (void)SvPOK_only(targ);
188 TAINT_IF(cx->sb_rxtainted);
192 LEAVE_SCOPE(cx->sb_oldsave);
194 RETURNOP(pm->op_next);
197 if (rx->subbase && rx->subbase != orig) {
200 cx->sb_orig = orig = rx->subbase;
202 cx->sb_strend = s + (cx->sb_strend - m);
204 cx->sb_m = m = rx->startp[0];
205 sv_catpvn(dstr, s, m-s);
206 cx->sb_s = rx->endp[0];
207 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
208 rxres_save(&cx->sb_rxres, rx);
209 RETURNOP(pm->op_pmreplstart);
213 rxres_save(void **rsp, REGEXP *rx)
218 if (!p || p[1] < rx->nparens) {
219 i = 6 + rx->nparens * 2;
227 *p++ = (UV)rx->subbase;
228 rx->subbase = Nullch;
232 *p++ = (UV)rx->subbeg;
233 *p++ = (UV)rx->subend;
234 for (i = 0; i <= rx->nparens; ++i) {
235 *p++ = (UV)rx->startp[i];
236 *p++ = (UV)rx->endp[i];
241 rxres_restore(void **rsp, REGEXP *rx)
246 Safefree(rx->subbase);
247 rx->subbase = (char*)(*p);
252 rx->subbeg = (char*)(*p++);
253 rx->subend = (char*)(*p++);
254 for (i = 0; i <= rx->nparens; ++i) {
255 rx->startp[i] = (char*)(*p++);
256 rx->endp[i] = (char*)(*p++);
261 rxres_free(void **rsp)
266 Safefree((char*)(*p));
274 djSP; dMARK; dORIGMARK;
275 register SV *tmpForm = *++MARK;
287 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
293 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
295 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
296 SvREADONLY_off(tmpForm);
297 doparseform(tmpForm);
300 SvPV_force(PL_formtarget, len);
301 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
303 f = SvPV(tmpForm, len);
304 /* need to jump to the next word */
305 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
314 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
315 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
316 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
317 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
318 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
320 case FF_CHECKNL: name = "CHECKNL"; break;
321 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
322 case FF_SPACE: name = "SPACE"; break;
323 case FF_HALFSPACE: name = "HALFSPACE"; break;
324 case FF_ITEM: name = "ITEM"; break;
325 case FF_CHOP: name = "CHOP"; break;
326 case FF_LINEGLOB: name = "LINEGLOB"; break;
327 case FF_NEWLINE: name = "NEWLINE"; break;
328 case FF_MORE: name = "MORE"; break;
329 case FF_LINEMARK: name = "LINEMARK"; break;
330 case FF_END: name = "END"; break;
333 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
335 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
363 if (ckWARN(WARN_SYNTAX))
364 warner(WARN_SYNTAX, "Not enough format arguments");
369 item = s = SvPV(sv, len);
372 itemsize = sv_len_utf8(sv);
373 if (itemsize != len) {
375 if (itemsize > fieldsize) {
376 itemsize = fieldsize;
377 itembytes = itemsize;
378 sv_pos_u2b(sv, &itembytes, 0);
382 send = chophere = s + itembytes;
391 sv_pos_b2u(sv, &itemsize);
395 if (itemsize > fieldsize)
396 itemsize = fieldsize;
397 send = chophere = s + itemsize;
409 item = s = SvPV(sv, len);
412 itemsize = sv_len_utf8(sv);
413 if (itemsize != len) {
415 if (itemsize <= fieldsize) {
416 send = chophere = s + itemsize;
427 itemsize = fieldsize;
428 itembytes = itemsize;
429 sv_pos_u2b(sv, &itembytes, 0);
430 send = chophere = s + itembytes;
431 while (s < send || (s == send && isSPACE(*s))) {
441 if (strchr(PL_chopset, *s))
446 itemsize = chophere - item;
447 sv_pos_b2u(sv, &itemsize);
452 if (itemsize <= fieldsize) {
453 send = chophere = s + itemsize;
464 itemsize = fieldsize;
465 send = chophere = s + itemsize;
466 while (s < send || (s == send && isSPACE(*s))) {
476 if (strchr(PL_chopset, *s))
481 itemsize = chophere - item;
486 arg = fieldsize - itemsize;
495 arg = fieldsize - itemsize;
510 switch (UTF8SKIP(s)) {
521 if ( !((*t++ = *s++) & ~31) )
529 int ch = *t++ = *s++;
532 if ( !((*t++ = *s++) & ~31) )
541 while (*s && isSPACE(*s))
548 item = s = SvPV(sv, len);
561 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
562 sv_catpvn(PL_formtarget, item, itemsize);
563 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
564 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
569 /* If the field is marked with ^ and the value is undefined,
572 if ((arg & 512) && !SvOK(sv)) {
580 /* Formats aren't yet marked for locales, so assume "yes". */
583 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
585 sprintf(t, "%*.0f", (int) fieldsize, value);
592 while (t-- > linemark && *t == ' ') ;
600 if (arg) { /* repeat until fields exhausted? */
602 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
603 lines += FmLINES(PL_formtarget);
606 if (strnEQ(linemark, linemark - arg, arg))
607 DIE("Runaway format");
609 FmLINES(PL_formtarget) = lines;
611 RETURNOP(cLISTOP->op_first);
624 while (*s && isSPACE(*s) && s < send)
628 arg = fieldsize - itemsize;
635 if (strnEQ(s," ",3)) {
636 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
647 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
648 FmLINES(PL_formtarget) += lines;
660 if (PL_stack_base + *PL_markstack_ptr == SP) {
662 if (GIMME_V == G_SCALAR)
664 RETURNOP(PL_op->op_next->op_next);
666 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
667 pp_pushmark(ARGS); /* push dst */
668 pp_pushmark(ARGS); /* push src */
669 ENTER; /* enter outer scope */
672 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
674 ENTER; /* enter inner scope */
677 src = PL_stack_base[*PL_markstack_ptr];
682 if (PL_op->op_type == OP_MAPSTART)
683 pp_pushmark(ARGS); /* push top */
684 return ((LOGOP*)PL_op->op_next)->op_other;
689 DIE("panic: mapstart"); /* uses grepstart */
695 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
701 ++PL_markstack_ptr[-1];
703 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
704 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
705 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
710 PL_markstack_ptr[-1] += shift;
711 *PL_markstack_ptr += shift;
715 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
718 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
720 LEAVE; /* exit inner scope */
723 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
727 (void)POPMARK; /* pop top */
728 LEAVE; /* exit outer scope */
729 (void)POPMARK; /* pop src */
730 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
731 (void)POPMARK; /* pop dst */
732 SP = PL_stack_base + POPMARK; /* pop original mark */
733 if (gimme == G_SCALAR) {
737 else if (gimme == G_ARRAY)
744 ENTER; /* enter inner scope */
747 src = PL_stack_base[PL_markstack_ptr[-1]];
751 RETURNOP(cLOGOP->op_other);
755 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
757 if (PL_amagic_generation) { \
758 if (SvAMAGIC(left)||SvAMAGIC(right))\
759 *svp = amagic_call(left, \
767 amagic_cmp(register SV *str1, register SV *str2)
770 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
775 I32 i = SvIVX(tmpsv);
785 return sv_cmp(str1, str2);
789 amagic_cmp_locale(register SV *str1, register SV *str2)
792 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
797 I32 i = SvIVX(tmpsv);
807 return sv_cmp_locale(str1, str2);
812 djSP; dMARK; dORIGMARK;
814 SV **myorigmark = ORIGMARK;
820 OP* nextop = PL_op->op_next;
823 if (gimme != G_ARRAY) {
829 SAVEPPTR(PL_sortcop);
830 if (PL_op->op_flags & OPf_STACKED) {
831 if (PL_op->op_flags & OPf_SPECIAL) {
832 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
833 kid = kUNOP->op_first; /* pass rv2gv */
834 kid = kUNOP->op_first; /* pass leave */
835 PL_sortcop = kid->op_next;
836 stash = PL_curcop->cop_stash;
839 cv = sv_2cv(*++MARK, &stash, &gv, 0);
840 if (!(cv && CvROOT(cv))) {
842 SV *tmpstr = sv_newmortal();
843 gv_efullname3(tmpstr, gv, Nullch);
844 if (cv && CvXSUB(cv))
845 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
846 DIE("Undefined sort subroutine \"%s\" called",
851 DIE("Xsub called in sort");
852 DIE("Undefined subroutine in sort");
854 DIE("Not a CODE reference in sort");
856 PL_sortcop = CvSTART(cv);
857 SAVESPTR(CvROOT(cv)->op_ppaddr);
858 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
861 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
866 stash = PL_curcop->cop_stash;
870 while (MARK < SP) { /* This may or may not shift down one here. */
872 if (*up = *++MARK) { /* Weed out nulls. */
874 if (!PL_sortcop && !SvPOK(*up)) {
878 (void)sv_2pv(*up, &PL_na);
883 max = --up - myorigmark;
888 bool oldcatch = CATCH_GET;
894 PUSHSTACKi(PERLSI_SORT);
895 if (PL_sortstash != stash) {
896 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
897 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
898 PL_sortstash = stash;
901 SAVESPTR(GvSV(PL_firstgv));
902 SAVESPTR(GvSV(PL_secondgv));
904 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
905 if (!(PL_op->op_flags & OPf_SPECIAL)) {
906 bool hasargs = FALSE;
907 cx->cx_type = CXt_SUB;
908 cx->blk_gimme = G_SCALAR;
911 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
913 PL_sortcxix = cxstack_ix;
914 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
916 POPBLOCK(cx,PL_curpm);
924 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
925 qsortsv(ORIGMARK+1, max,
926 (PL_op->op_private & OPpLOCALE)
928 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
929 : FUNC_NAME_TO_PTR(sv_cmp_locale))
931 ? FUNC_NAME_TO_PTR(amagic_cmp)
932 : FUNC_NAME_TO_PTR(sv_cmp) ));
936 PL_stack_sp = ORIGMARK + max;
944 if (GIMME == G_ARRAY)
945 return cCONDOP->op_true;
946 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
953 if (GIMME == G_ARRAY) {
954 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
958 SV *targ = PAD_SV(PL_op->op_targ);
960 if ((PL_op->op_private & OPpFLIP_LINENUM)
961 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
963 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
964 if (PL_op->op_flags & OPf_SPECIAL) {
972 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
985 if (GIMME == G_ARRAY) {
991 if (SvNIOKp(left) || !SvPOKp(left) ||
992 (looks_like_number(left) && *SvPVX(left) != '0') )
994 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
995 croak("Range iterator outside integer range");
999 EXTEND_MORTAL(max - i + 1);
1000 EXTEND(SP, max - i + 1);
1003 sv = sv_2mortal(newSViv(i++));
1008 SV *final = sv_mortalcopy(right);
1010 char *tmps = SvPV(final, len);
1012 sv = sv_mortalcopy(left);
1013 SvPV_force(sv,PL_na);
1014 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1016 if (strEQ(SvPVX(sv),tmps))
1018 sv = sv_2mortal(newSVsv(sv));
1025 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1027 if ((PL_op->op_private & OPpFLIP_LINENUM)
1028 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1030 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1031 sv_catpv(targ, "E0");
1042 dopoptolabel(char *label)
1046 register PERL_CONTEXT *cx;
1048 for (i = cxstack_ix; i >= 0; i--) {
1050 switch (CxTYPE(cx)) {
1052 if (ckWARN(WARN_UNSAFE))
1053 warner(WARN_UNSAFE, "Exiting substitution via %s",
1054 PL_op_name[PL_op->op_type]);
1057 if (ckWARN(WARN_UNSAFE))
1058 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1059 PL_op_name[PL_op->op_type]);
1062 if (ckWARN(WARN_UNSAFE))
1063 warner(WARN_UNSAFE, "Exiting eval via %s",
1064 PL_op_name[PL_op->op_type]);
1067 if (ckWARN(WARN_UNSAFE))
1068 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1069 PL_op_name[PL_op->op_type]);
1072 if (!cx->blk_loop.label ||
1073 strNE(label, cx->blk_loop.label) ) {
1074 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1075 (long)i, cx->blk_loop.label));
1078 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1088 I32 gimme = block_gimme();
1089 return (gimme == G_VOID) ? G_SCALAR : gimme;
1098 cxix = dopoptosub(cxstack_ix);
1102 switch (cxstack[cxix].blk_gimme) {
1110 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1117 dopoptosub(I32 startingblock)
1120 return dopoptosub_at(cxstack, startingblock);
1124 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1128 register PERL_CONTEXT *cx;
1129 for (i = startingblock; i >= 0; i--) {
1131 switch (CxTYPE(cx)) {
1136 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1144 dopoptoeval(I32 startingblock)
1148 register PERL_CONTEXT *cx;
1149 for (i = startingblock; i >= 0; i--) {
1151 switch (CxTYPE(cx)) {
1155 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1163 dopoptoloop(I32 startingblock)
1167 register PERL_CONTEXT *cx;
1168 for (i = startingblock; i >= 0; i--) {
1170 switch (CxTYPE(cx)) {
1172 if (ckWARN(WARN_UNSAFE))
1173 warner(WARN_UNSAFE, "Exiting substitution via %s",
1174 PL_op_name[PL_op->op_type]);
1177 if (ckWARN(WARN_UNSAFE))
1178 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1179 PL_op_name[PL_op->op_type]);
1182 if (ckWARN(WARN_UNSAFE))
1183 warner(WARN_UNSAFE, "Exiting eval via %s",
1184 PL_op_name[PL_op->op_type]);
1187 if (ckWARN(WARN_UNSAFE))
1188 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1189 PL_op_name[PL_op->op_type]);
1192 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1203 register PERL_CONTEXT *cx;
1207 while (cxstack_ix > cxix) {
1208 cx = &cxstack[cxstack_ix];
1209 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1210 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1211 /* Note: we don't need to restore the base context info till the end. */
1212 switch (CxTYPE(cx)) {
1215 continue; /* not break */
1233 die_where(char *message)
1238 register PERL_CONTEXT *cx;
1243 if (PL_in_eval & 4) {
1245 STRLEN klen = strlen(message);
1247 svp = hv_fetch(ERRHV, message, klen, TRUE);
1250 static char prefix[] = "\t(in cleanup) ";
1252 sv_upgrade(*svp, SVt_IV);
1253 (void)SvIOK_only(*svp);
1256 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1257 sv_catpvn(err, prefix, sizeof(prefix)-1);
1258 sv_catpvn(err, message, klen);
1259 if (ckWARN(WARN_UNSAFE)) {
1260 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1261 warner(WARN_UNSAFE, SvPVX(err)+start);
1268 sv_setpv(ERRSV, message);
1271 message = SvPVx(ERRSV, PL_na);
1273 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1281 if (cxix < cxstack_ix)
1284 POPBLOCK(cx,PL_curpm);
1285 if (CxTYPE(cx) != CXt_EVAL) {
1286 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1291 if (gimme == G_SCALAR)
1292 *++newsp = &PL_sv_undef;
1293 PL_stack_sp = newsp;
1297 if (optype == OP_REQUIRE) {
1298 char* msg = SvPVx(ERRSV, PL_na);
1299 DIE("%s", *msg ? msg : "Compilation failed in require");
1301 return pop_return();
1305 message = SvPVx(ERRSV, PL_na);
1306 PerlIO_printf(PerlIO_stderr(), "%s",message);
1307 PerlIO_flush(PerlIO_stderr());
1316 if (SvTRUE(left) != SvTRUE(right))
1328 RETURNOP(cLOGOP->op_other);
1337 RETURNOP(cLOGOP->op_other);
1343 register I32 cxix = dopoptosub(cxstack_ix);
1344 register PERL_CONTEXT *cx;
1345 register PERL_CONTEXT *ccstack = cxstack;
1346 PERL_SI *top_si = PL_curstackinfo;
1357 /* we may be in a higher stacklevel, so dig down deeper */
1358 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1359 top_si = top_si->si_prev;
1360 ccstack = top_si->si_cxstack;
1361 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1364 if (GIMME != G_ARRAY)
1368 if (PL_DBsub && cxix >= 0 &&
1369 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1373 cxix = dopoptosub_at(ccstack, cxix - 1);
1376 cx = &ccstack[cxix];
1377 if (CxTYPE(cx) == CXt_SUB) {
1378 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1379 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1380 field below is defined for any cx. */
1381 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1382 cx = &ccstack[dbcxix];
1385 if (GIMME != G_ARRAY) {
1386 hv = cx->blk_oldcop->cop_stash;
1388 PUSHs(&PL_sv_undef);
1391 sv_setpv(TARG, HvNAME(hv));
1397 hv = cx->blk_oldcop->cop_stash;
1399 PUSHs(&PL_sv_undef);
1401 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1402 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1403 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1406 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1408 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1409 PUSHs(sv_2mortal(sv));
1410 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1413 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1414 PUSHs(sv_2mortal(newSViv(0)));
1416 gimme = (I32)cx->blk_gimme;
1417 if (gimme == G_VOID)
1418 PUSHs(&PL_sv_undef);
1420 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1421 if (CxTYPE(cx) == CXt_EVAL) {
1422 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1423 PUSHs(cx->blk_eval.cur_text);
1426 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1427 /* Require, put the name. */
1428 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1432 else if (CxTYPE(cx) == CXt_SUB &&
1433 cx->blk_sub.hasargs &&
1434 PL_curcop->cop_stash == PL_debstash)
1436 AV *ary = cx->blk_sub.argarray;
1437 int off = AvARRAY(ary) - AvALLOC(ary);
1441 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1444 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1447 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1448 av_extend(PL_dbargs, AvFILLp(ary) + off);
1449 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1450 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1456 sortcv(SV *a, SV *b)
1459 I32 oldsaveix = PL_savestack_ix;
1460 I32 oldscopeix = PL_scopestack_ix;
1462 GvSV(PL_firstgv) = a;
1463 GvSV(PL_secondgv) = b;
1464 PL_stack_sp = PL_stack_base;
1467 if (PL_stack_sp != PL_stack_base + 1)
1468 croak("Sort subroutine didn't return single value");
1469 if (!SvNIOKp(*PL_stack_sp))
1470 croak("Sort subroutine didn't return a numeric value");
1471 result = SvIV(*PL_stack_sp);
1472 while (PL_scopestack_ix > oldscopeix) {
1475 leave_scope(oldsaveix);
1488 sv_reset(tmps, PL_curcop->cop_stash);
1500 PL_curcop = (COP*)PL_op;
1501 TAINT_NOT; /* Each statement is presumed innocent */
1502 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1505 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1509 register PERL_CONTEXT *cx;
1510 I32 gimme = G_ARRAY;
1517 DIE("No DB::DB routine defined");
1519 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1531 push_return(PL_op->op_next);
1532 PUSHBLOCK(cx, CXt_SUB, SP);
1535 (void)SvREFCNT_inc(cv);
1536 SAVESPTR(PL_curpad);
1537 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1538 RETURNOP(CvSTART(cv));
1552 register PERL_CONTEXT *cx;
1553 I32 gimme = GIMME_V;
1560 if (PL_op->op_flags & OPf_SPECIAL)
1561 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1563 #endif /* USE_THREADS */
1564 if (PL_op->op_targ) {
1565 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1570 (void)save_scalar(gv);
1571 svp = &GvSV(gv); /* symbol table variable */
1576 PUSHBLOCK(cx, CXt_LOOP, SP);
1577 PUSHLOOP(cx, svp, MARK);
1578 if (PL_op->op_flags & OPf_STACKED) {
1579 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1580 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1582 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1583 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1584 if (SvNV(sv) < IV_MIN ||
1585 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1586 croak("Range iterator outside integer range");
1587 cx->blk_loop.iterix = SvIV(sv);
1588 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1591 cx->blk_loop.iterlval = newSVsv(sv);
1595 cx->blk_loop.iterary = PL_curstack;
1596 AvFILLp(PL_curstack) = SP - PL_stack_base;
1597 cx->blk_loop.iterix = MARK - PL_stack_base;
1606 register PERL_CONTEXT *cx;
1607 I32 gimme = GIMME_V;
1613 PUSHBLOCK(cx, CXt_LOOP, SP);
1614 PUSHLOOP(cx, 0, SP);
1622 register PERL_CONTEXT *cx;
1623 struct block_loop cxloop;
1631 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1634 if (gimme == G_VOID)
1636 else if (gimme == G_SCALAR) {
1638 *++newsp = sv_mortalcopy(*SP);
1640 *++newsp = &PL_sv_undef;
1644 *++newsp = sv_mortalcopy(*++mark);
1645 TAINT_NOT; /* Each item is independent */
1651 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1652 PL_curpm = newpm; /* ... and pop $1 et al */
1664 register PERL_CONTEXT *cx;
1665 struct block_sub cxsub;
1666 bool popsub2 = FALSE;
1672 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1673 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1674 if (cxstack_ix > PL_sortcxix)
1675 dounwind(PL_sortcxix);
1676 AvARRAY(PL_curstack)[1] = *SP;
1677 PL_stack_sp = PL_stack_base + 1;
1682 cxix = dopoptosub(cxstack_ix);
1684 DIE("Can't return outside a subroutine");
1685 if (cxix < cxstack_ix)
1689 switch (CxTYPE(cx)) {
1691 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1696 if (optype == OP_REQUIRE &&
1697 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1699 /* Unassume the success we assumed earlier. */
1700 char *name = cx->blk_eval.old_name;
1701 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1702 DIE("%s did not return a true value", name);
1706 DIE("panic: return");
1710 if (gimme == G_SCALAR) {
1713 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1715 *++newsp = SvREFCNT_inc(*SP);
1720 *++newsp = sv_mortalcopy(*SP);
1723 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1725 *++newsp = sv_mortalcopy(*SP);
1727 *++newsp = &PL_sv_undef;
1729 else if (gimme == G_ARRAY) {
1730 while (++MARK <= SP) {
1731 *++newsp = (popsub2 && SvTEMP(*MARK))
1732 ? *MARK : sv_mortalcopy(*MARK);
1733 TAINT_NOT; /* Each item is independent */
1736 PL_stack_sp = newsp;
1738 /* Stack values are safe: */
1740 POPSUB2(); /* release CV and @_ ... */
1742 PL_curpm = newpm; /* ... and pop $1 et al */
1745 return pop_return();
1752 register PERL_CONTEXT *cx;
1753 struct block_loop cxloop;
1754 struct block_sub cxsub;
1761 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1763 if (PL_op->op_flags & OPf_SPECIAL) {
1764 cxix = dopoptoloop(cxstack_ix);
1766 DIE("Can't \"last\" outside a block");
1769 cxix = dopoptolabel(cPVOP->op_pv);
1771 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1773 if (cxix < cxstack_ix)
1777 switch (CxTYPE(cx)) {
1779 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1781 nextop = cxloop.last_op->op_next;
1784 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1786 nextop = pop_return();
1790 nextop = pop_return();
1797 if (gimme == G_SCALAR) {
1799 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1800 ? *SP : sv_mortalcopy(*SP);
1802 *++newsp = &PL_sv_undef;
1804 else if (gimme == G_ARRAY) {
1805 while (++MARK <= SP) {
1806 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1807 ? *MARK : sv_mortalcopy(*MARK);
1808 TAINT_NOT; /* Each item is independent */
1814 /* Stack values are safe: */
1817 POPLOOP2(); /* release loop vars ... */
1821 POPSUB2(); /* release CV and @_ ... */
1824 PL_curpm = newpm; /* ... and pop $1 et al */
1833 register PERL_CONTEXT *cx;
1836 if (PL_op->op_flags & OPf_SPECIAL) {
1837 cxix = dopoptoloop(cxstack_ix);
1839 DIE("Can't \"next\" outside a block");
1842 cxix = dopoptolabel(cPVOP->op_pv);
1844 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1846 if (cxix < cxstack_ix)
1850 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1851 LEAVE_SCOPE(oldsave);
1852 return cx->blk_loop.next_op;
1858 register PERL_CONTEXT *cx;
1861 if (PL_op->op_flags & OPf_SPECIAL) {
1862 cxix = dopoptoloop(cxstack_ix);
1864 DIE("Can't \"redo\" outside a block");
1867 cxix = dopoptolabel(cPVOP->op_pv);
1869 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1871 if (cxix < cxstack_ix)
1875 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1876 LEAVE_SCOPE(oldsave);
1877 return cx->blk_loop.redo_op;
1881 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1885 static char too_deep[] = "Target of goto is too deeply nested";
1889 if (o->op_type == OP_LEAVE ||
1890 o->op_type == OP_SCOPE ||
1891 o->op_type == OP_LEAVELOOP ||
1892 o->op_type == OP_LEAVETRY)
1894 *ops++ = cUNOPo->op_first;
1899 if (o->op_flags & OPf_KIDS) {
1901 /* First try all the kids at this level, since that's likeliest. */
1902 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1903 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1904 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1907 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1908 if (kid == PL_lastgotoprobe)
1910 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1912 (ops[-1]->op_type != OP_NEXTSTATE &&
1913 ops[-1]->op_type != OP_DBSTATE)))
1915 if (o = dofindlabel(kid, label, ops, oplimit))
1925 return pp_goto(ARGS);
1934 register PERL_CONTEXT *cx;
1935 #define GOTO_DEPTH 64
1936 OP *enterops[GOTO_DEPTH];
1938 int do_dump = (PL_op->op_type == OP_DUMP);
1941 if (PL_op->op_flags & OPf_STACKED) {
1944 /* This egregious kludge implements goto &subroutine */
1945 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1947 register PERL_CONTEXT *cx;
1948 CV* cv = (CV*)SvRV(sv);
1952 int arg_was_real = 0;
1955 if (!CvROOT(cv) && !CvXSUB(cv)) {
1960 /* autoloaded stub? */
1961 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1963 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1964 GvNAMELEN(gv), FALSE);
1965 if (autogv && (cv = GvCV(autogv)))
1967 tmpstr = sv_newmortal();
1968 gv_efullname3(tmpstr, gv, Nullch);
1969 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1971 DIE("Goto undefined subroutine");
1974 /* First do some returnish stuff. */
1975 cxix = dopoptosub(cxstack_ix);
1977 DIE("Can't goto subroutine outside a subroutine");
1978 if (cxix < cxstack_ix)
1981 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1982 DIE("Can't goto subroutine from an eval-string");
1984 if (CxTYPE(cx) == CXt_SUB &&
1985 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1986 AV* av = cx->blk_sub.argarray;
1988 items = AvFILLp(av) + 1;
1990 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1991 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1992 PL_stack_sp += items;
1994 SvREFCNT_dec(GvAV(PL_defgv));
1995 GvAV(PL_defgv) = cx->blk_sub.savearray;
1996 #endif /* USE_THREADS */
1999 AvREAL_off(av); /* so av_clear() won't clobber elts */
2003 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2007 av = (AV*)PL_curpad[0];
2009 av = GvAV(PL_defgv);
2011 items = AvFILLp(av) + 1;
2013 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2014 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2015 PL_stack_sp += items;
2017 if (CxTYPE(cx) == CXt_SUB &&
2018 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2019 SvREFCNT_dec(cx->blk_sub.cv);
2020 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2021 LEAVE_SCOPE(oldsave);
2023 /* Now do some callish stuff. */
2026 if (CvOLDSTYLE(cv)) {
2027 I32 (*fp3)_((int,int,int));
2032 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2033 items = (*fp3)(CvXSUBANY(cv).any_i32,
2034 mark - PL_stack_base + 1,
2036 SP = PL_stack_base + items;
2042 PL_stack_sp--; /* There is no cv arg. */
2043 /* Push a mark for the start of arglist */
2045 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2046 /* Pop the current context like a decent sub should */
2047 POPBLOCK(cx, PL_curpm);
2048 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2051 return pop_return();
2054 AV* padlist = CvPADLIST(cv);
2055 SV** svp = AvARRAY(padlist);
2056 if (CxTYPE(cx) == CXt_EVAL) {
2057 PL_in_eval = cx->blk_eval.old_in_eval;
2058 PL_eval_root = cx->blk_eval.old_eval_root;
2059 cx->cx_type = CXt_SUB;
2060 cx->blk_sub.hasargs = 0;
2062 cx->blk_sub.cv = cv;
2063 cx->blk_sub.olddepth = CvDEPTH(cv);
2065 if (CvDEPTH(cv) < 2)
2066 (void)SvREFCNT_inc(cv);
2067 else { /* save temporaries on recursion? */
2068 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2069 sub_crush_depth(cv);
2070 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2071 AV *newpad = newAV();
2072 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2073 I32 ix = AvFILLp((AV*)svp[1]);
2074 svp = AvARRAY(svp[0]);
2075 for ( ;ix > 0; ix--) {
2076 if (svp[ix] != &PL_sv_undef) {
2077 char *name = SvPVX(svp[ix]);
2078 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2081 /* outer lexical or anon code */
2082 av_store(newpad, ix,
2083 SvREFCNT_inc(oldpad[ix]) );
2085 else { /* our own lexical */
2087 av_store(newpad, ix, sv = (SV*)newAV());
2088 else if (*name == '%')
2089 av_store(newpad, ix, sv = (SV*)newHV());
2091 av_store(newpad, ix, sv = NEWSV(0,0));
2096 av_store(newpad, ix, sv = NEWSV(0,0));
2100 if (cx->blk_sub.hasargs) {
2103 av_store(newpad, 0, (SV*)av);
2104 AvFLAGS(av) = AVf_REIFY;
2106 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2107 AvFILLp(padlist) = CvDEPTH(cv);
2108 svp = AvARRAY(padlist);
2112 if (!cx->blk_sub.hasargs) {
2113 AV* av = (AV*)PL_curpad[0];
2115 items = AvFILLp(av) + 1;
2117 /* Mark is at the end of the stack. */
2119 Copy(AvARRAY(av), SP + 1, items, SV*);
2124 #endif /* USE_THREADS */
2125 SAVESPTR(PL_curpad);
2126 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2128 if (cx->blk_sub.hasargs)
2129 #endif /* USE_THREADS */
2131 AV* av = (AV*)PL_curpad[0];
2135 cx->blk_sub.savearray = GvAV(PL_defgv);
2136 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2137 #endif /* USE_THREADS */
2138 cx->blk_sub.argarray = av;
2141 if (items >= AvMAX(av) + 1) {
2143 if (AvARRAY(av) != ary) {
2144 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2145 SvPVX(av) = (char*)ary;
2147 if (items >= AvMAX(av) + 1) {
2148 AvMAX(av) = items - 1;
2149 Renew(ary,items+1,SV*);
2151 SvPVX(av) = (char*)ary;
2154 Copy(mark,AvARRAY(av),items,SV*);
2155 AvFILLp(av) = items - 1;
2156 /* preserve @_ nature */
2167 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2169 * We do not care about using sv to call CV;
2170 * it's for informational purposes only.
2172 SV *sv = GvSV(PL_DBsub);
2175 if (PERLDB_SUB_NN) {
2176 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2179 gv_efullname3(sv, CvGV(cv), Nullch);
2182 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2183 PUSHMARK( PL_stack_sp );
2184 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2188 RETURNOP(CvSTART(cv));
2192 label = SvPV(sv,PL_na);
2194 else if (PL_op->op_flags & OPf_SPECIAL) {
2196 DIE("goto must have label");
2199 label = cPVOP->op_pv;
2201 if (label && *label) {
2206 PL_lastgotoprobe = 0;
2208 for (ix = cxstack_ix; ix >= 0; ix--) {
2210 switch (CxTYPE(cx)) {
2212 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2215 gotoprobe = cx->blk_oldcop->op_sibling;
2221 gotoprobe = cx->blk_oldcop->op_sibling;
2223 gotoprobe = PL_main_root;
2226 if (CvDEPTH(cx->blk_sub.cv)) {
2227 gotoprobe = CvROOT(cx->blk_sub.cv);
2232 DIE("Can't \"goto\" outside a block");
2236 gotoprobe = PL_main_root;
2239 retop = dofindlabel(gotoprobe, label,
2240 enterops, enterops + GOTO_DEPTH);
2243 PL_lastgotoprobe = gotoprobe;
2246 DIE("Can't find label %s", label);
2248 /* pop unwanted frames */
2250 if (ix < cxstack_ix) {
2257 oldsave = PL_scopestack[PL_scopestack_ix];
2258 LEAVE_SCOPE(oldsave);
2261 /* push wanted frames */
2263 if (*enterops && enterops[1]) {
2265 for (ix = 1; enterops[ix]; ix++) {
2266 PL_op = enterops[ix];
2267 /* Eventually we may want to stack the needed arguments
2268 * for each op. For now, we punt on the hard ones. */
2269 if (PL_op->op_type == OP_ENTERITER)
2270 DIE("Can't \"goto\" into the middle of a foreach loop",
2272 (CALLOP->op_ppaddr)(ARGS);
2280 if (!retop) retop = PL_main_start;
2282 PL_restartop = retop;
2283 PL_do_undump = TRUE;
2287 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2288 PL_do_undump = FALSE;
2304 if (anum == 1 && VMSISH_EXIT)
2309 PUSHs(&PL_sv_undef);
2317 double value = SvNVx(GvSV(cCOP->cop_gv));
2318 register I32 match = I_32(value);
2321 if (((double)match) > value)
2322 --match; /* was fractional--truncate other way */
2324 match -= cCOP->uop.scop.scop_offset;
2327 else if (match > cCOP->uop.scop.scop_max)
2328 match = cCOP->uop.scop.scop_max;
2329 PL_op = cCOP->uop.scop.scop_next[match];
2339 PL_op = PL_op->op_next; /* can't assume anything */
2341 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2342 match -= cCOP->uop.scop.scop_offset;
2345 else if (match > cCOP->uop.scop.scop_max)
2346 match = cCOP->uop.scop.scop_max;
2347 PL_op = cCOP->uop.scop.scop_next[match];
2356 save_lines(AV *array, SV *sv)
2358 register char *s = SvPVX(sv);
2359 register char *send = SvPVX(sv) + SvCUR(sv);
2361 register I32 line = 1;
2363 while (s && s < send) {
2364 SV *tmpstr = NEWSV(85,0);
2366 sv_upgrade(tmpstr, SVt_PVMG);
2367 t = strchr(s, '\n');
2373 sv_setpvn(tmpstr, s, t - s);
2374 av_store(array, line++, tmpstr);
2389 assert(CATCH_GET == TRUE);
2390 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2394 default: /* topmost level handles it */
2403 PL_op = PL_restartop;
2416 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2417 /* sv Text to convert to OP tree. */
2418 /* startop op_free() this to undo. */
2419 /* code Short string id of the caller. */
2421 dSP; /* Make POPBLOCK work. */
2424 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2427 OP *oop = PL_op, *rop;
2428 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2434 /* switch to eval mode */
2436 if (PL_curcop == &PL_compiling) {
2437 SAVESPTR(PL_compiling.cop_stash);
2438 PL_compiling.cop_stash = PL_curstash;
2440 SAVESPTR(PL_compiling.cop_filegv);
2441 SAVEI16(PL_compiling.cop_line);
2442 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2443 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2444 PL_compiling.cop_line = 1;
2445 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2446 deleting the eval's FILEGV from the stash before gv_check() runs
2447 (i.e. before run-time proper). To work around the coredump that
2448 ensues, we always turn GvMULTI_on for any globals that were
2449 introduced within evals. See force_ident(). GSAR 96-10-12 */
2450 safestr = savepv(tmpbuf);
2451 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2453 #ifdef OP_IN_REGISTER
2461 PL_op->op_type = OP_ENTEREVAL;
2462 PL_op->op_flags = 0; /* Avoid uninit warning. */
2463 PUSHBLOCK(cx, CXt_EVAL, SP);
2464 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2465 rop = doeval(G_SCALAR, startop);
2466 POPBLOCK(cx,PL_curpm);
2469 (*startop)->op_type = OP_NULL;
2470 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2472 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2474 if (PL_curcop == &PL_compiling)
2475 PL_compiling.op_private = PL_hints;
2476 #ifdef OP_IN_REGISTER
2482 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2484 doeval(int gimme, OP** startop)
2497 /* set up a scratch pad */
2500 SAVESPTR(PL_curpad);
2501 SAVESPTR(PL_comppad);
2502 SAVESPTR(PL_comppad_name);
2503 SAVEI32(PL_comppad_name_fill);
2504 SAVEI32(PL_min_intro_pending);
2505 SAVEI32(PL_max_intro_pending);
2508 for (i = cxstack_ix - 1; i >= 0; i--) {
2509 PERL_CONTEXT *cx = &cxstack[i];
2510 if (CxTYPE(cx) == CXt_EVAL)
2512 else if (CxTYPE(cx) == CXt_SUB) {
2513 caller = cx->blk_sub.cv;
2518 SAVESPTR(PL_compcv);
2519 PL_compcv = (CV*)NEWSV(1104,0);
2520 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2521 CvUNIQUE_on(PL_compcv);
2523 CvOWNER(PL_compcv) = 0;
2524 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2525 MUTEX_INIT(CvMUTEXP(PL_compcv));
2526 #endif /* USE_THREADS */
2528 PL_comppad = newAV();
2529 av_push(PL_comppad, Nullsv);
2530 PL_curpad = AvARRAY(PL_comppad);
2531 PL_comppad_name = newAV();
2532 PL_comppad_name_fill = 0;
2533 PL_min_intro_pending = 0;
2536 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2537 PL_curpad[0] = (SV*)newAV();
2538 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2539 #endif /* USE_THREADS */
2541 comppadlist = newAV();
2542 AvREAL_off(comppadlist);
2543 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2544 av_store(comppadlist, 1, (SV*)PL_comppad);
2545 CvPADLIST(PL_compcv) = comppadlist;
2547 if (!saveop || saveop->op_type != OP_REQUIRE)
2548 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2550 SAVEFREESV(PL_compcv);
2552 /* make sure we compile in the right package */
2554 newstash = PL_curcop->cop_stash;
2555 if (PL_curstash != newstash) {
2556 SAVESPTR(PL_curstash);
2557 PL_curstash = newstash;
2559 SAVESPTR(PL_beginav);
2560 PL_beginav = newAV();
2561 SAVEFREESV(PL_beginav);
2563 /* try to compile it */
2565 PL_eval_root = Nullop;
2567 PL_curcop = &PL_compiling;
2568 PL_curcop->cop_arybase = 0;
2569 SvREFCNT_dec(PL_rs);
2570 PL_rs = newSVpv("\n", 1);
2571 if (saveop && saveop->op_flags & OPf_SPECIAL)
2575 if (yyparse() || PL_error_count || !PL_eval_root) {
2579 I32 optype = 0; /* Might be reset by POPEVAL. */
2583 op_free(PL_eval_root);
2584 PL_eval_root = Nullop;
2586 SP = PL_stack_base + POPMARK; /* pop original mark */
2588 POPBLOCK(cx,PL_curpm);
2594 if (optype == OP_REQUIRE) {
2595 char* msg = SvPVx(ERRSV, PL_na);
2596 DIE("%s", *msg ? msg : "Compilation failed in require");
2597 } else if (startop) {
2598 char* msg = SvPVx(ERRSV, PL_na);
2600 POPBLOCK(cx,PL_curpm);
2602 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2604 SvREFCNT_dec(PL_rs);
2605 PL_rs = SvREFCNT_inc(PL_nrs);
2607 MUTEX_LOCK(&PL_eval_mutex);
2609 COND_SIGNAL(&PL_eval_cond);
2610 MUTEX_UNLOCK(&PL_eval_mutex);
2611 #endif /* USE_THREADS */
2614 SvREFCNT_dec(PL_rs);
2615 PL_rs = SvREFCNT_inc(PL_nrs);
2616 PL_compiling.cop_line = 0;
2618 *startop = PL_eval_root;
2619 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2620 CvOUTSIDE(PL_compcv) = Nullcv;
2622 SAVEFREEOP(PL_eval_root);
2624 scalarvoid(PL_eval_root);
2625 else if (gimme & G_ARRAY)
2628 scalar(PL_eval_root);
2630 DEBUG_x(dump_eval());
2632 /* Register with debugger: */
2633 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2634 CV *cv = perl_get_cv("DB::postponed", FALSE);
2638 XPUSHs((SV*)PL_compiling.cop_filegv);
2640 perl_call_sv((SV*)cv, G_DISCARD);
2644 /* compiled okay, so do it */
2646 CvDEPTH(PL_compcv) = 1;
2647 SP = PL_stack_base + POPMARK; /* pop original mark */
2648 PL_op = saveop; /* The caller may need it. */
2650 MUTEX_LOCK(&PL_eval_mutex);
2652 COND_SIGNAL(&PL_eval_cond);
2653 MUTEX_UNLOCK(&PL_eval_mutex);
2654 #endif /* USE_THREADS */
2656 RETURNOP(PL_eval_start);
2662 register PERL_CONTEXT *cx;
2667 SV *namesv = Nullsv;
2669 I32 gimme = G_SCALAR;
2670 PerlIO *tryrsfp = 0;
2673 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2674 SET_NUMERIC_STANDARD();
2675 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2676 DIE("Perl %s required--this is only version %s, stopped",
2677 SvPV(sv,PL_na),PL_patchlevel);
2680 name = SvPV(sv, len);
2681 if (!(name && len > 0 && *name))
2682 DIE("Null filename used");
2683 TAINT_PROPER("require");
2684 if (PL_op->op_type == OP_REQUIRE &&
2685 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2686 *svp != &PL_sv_undef)
2689 /* prepare to compile file */
2694 (name[1] == '.' && name[2] == '/')))
2696 || (name[0] && name[1] == ':')
2699 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2702 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2703 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2708 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2711 AV *ar = GvAVn(PL_incgv);
2715 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2718 namesv = NEWSV(806, 0);
2719 for (i = 0; i <= AvFILL(ar); i++) {
2720 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2723 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2725 sv_setpv(namesv, unixdir);
2726 sv_catpv(namesv, unixname);
2728 sv_setpvf(namesv, "%s/%s", dir, name);
2730 TAINT_PROPER("require");
2731 tryname = SvPVX(namesv);
2732 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2734 if (tryname[0] == '.' && tryname[1] == '/')
2741 SAVESPTR(PL_compiling.cop_filegv);
2742 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2743 SvREFCNT_dec(namesv);
2745 if (PL_op->op_type == OP_REQUIRE) {
2746 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2747 SV *dirmsgsv = NEWSV(0, 0);
2748 AV *ar = GvAVn(PL_incgv);
2750 if (instr(SvPVX(msg), ".h "))
2751 sv_catpv(msg, " (change .h to .ph maybe?)");
2752 if (instr(SvPVX(msg), ".ph "))
2753 sv_catpv(msg, " (did you run h2ph?)");
2754 sv_catpv(msg, " (@INC contains:");
2755 for (i = 0; i <= AvFILL(ar); i++) {
2756 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2757 sv_setpvf(dirmsgsv, " %s", dir);
2758 sv_catsv(msg, dirmsgsv);
2760 sv_catpvn(msg, ")", 1);
2761 SvREFCNT_dec(dirmsgsv);
2768 SETERRNO(0, SS$_NORMAL);
2770 /* Assume success here to prevent recursive requirement. */
2771 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2772 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2776 lex_start(sv_2mortal(newSVpv("",0)));
2777 SAVEGENERICSV(PL_rsfp_filters);
2778 PL_rsfp_filters = Nullav;
2781 name = savepv(name);
2785 SAVEPPTR(PL_compiling.cop_warnings);
2786 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2789 /* switch to eval mode */
2791 push_return(PL_op->op_next);
2792 PUSHBLOCK(cx, CXt_EVAL, SP);
2793 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2795 SAVEI16(PL_compiling.cop_line);
2796 PL_compiling.cop_line = 0;
2800 MUTEX_LOCK(&PL_eval_mutex);
2801 if (PL_eval_owner && PL_eval_owner != thr)
2802 while (PL_eval_owner)
2803 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2804 PL_eval_owner = thr;
2805 MUTEX_UNLOCK(&PL_eval_mutex);
2806 #endif /* USE_THREADS */
2807 return DOCATCH(doeval(G_SCALAR, NULL));
2812 return pp_require(ARGS);
2818 register PERL_CONTEXT *cx;
2820 I32 gimme = GIMME_V, was = PL_sub_generation;
2821 char tmpbuf[TYPE_DIGITS(long) + 12];
2826 if (!SvPV(sv,len) || !len)
2828 TAINT_PROPER("eval");
2834 /* switch to eval mode */
2836 SAVESPTR(PL_compiling.cop_filegv);
2837 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2838 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2839 PL_compiling.cop_line = 1;
2840 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2841 deleting the eval's FILEGV from the stash before gv_check() runs
2842 (i.e. before run-time proper). To work around the coredump that
2843 ensues, we always turn GvMULTI_on for any globals that were
2844 introduced within evals. See force_ident(). GSAR 96-10-12 */
2845 safestr = savepv(tmpbuf);
2846 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2848 PL_hints = PL_op->op_targ;
2849 SAVEPPTR(PL_compiling.cop_warnings);
2850 if (PL_compiling.cop_warnings != WARN_ALL
2851 && PL_compiling.cop_warnings != WARN_NONE){
2852 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2853 SAVEFREESV(PL_compiling.cop_warnings) ;
2856 push_return(PL_op->op_next);
2857 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2858 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2860 /* prepare to compile string */
2862 if (PERLDB_LINE && PL_curstash != PL_debstash)
2863 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2866 MUTEX_LOCK(&PL_eval_mutex);
2867 if (PL_eval_owner && PL_eval_owner != thr)
2868 while (PL_eval_owner)
2869 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2870 PL_eval_owner = thr;
2871 MUTEX_UNLOCK(&PL_eval_mutex);
2872 #endif /* USE_THREADS */
2873 ret = doeval(gimme, NULL);
2874 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2875 && ret != PL_op->op_next) { /* Successive compilation. */
2876 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2878 return DOCATCH(ret);
2888 register PERL_CONTEXT *cx;
2890 U8 save_flags = PL_op -> op_flags;
2895 retop = pop_return();
2898 if (gimme == G_VOID)
2900 else if (gimme == G_SCALAR) {
2903 if (SvFLAGS(TOPs) & SVs_TEMP)
2906 *MARK = sv_mortalcopy(TOPs);
2910 *MARK = &PL_sv_undef;
2914 /* in case LEAVE wipes old return values */
2915 for (mark = newsp + 1; mark <= SP; mark++) {
2916 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2917 *mark = sv_mortalcopy(*mark);
2918 TAINT_NOT; /* Each item is independent */
2922 PL_curpm = newpm; /* Don't pop $1 et al till now */
2925 * Closures mentioned at top level of eval cannot be referenced
2926 * again, and their presence indirectly causes a memory leak.
2927 * (Note that the fact that compcv and friends are still set here
2928 * is, AFAIK, an accident.) --Chip
2930 if (AvFILLp(PL_comppad_name) >= 0) {
2931 SV **svp = AvARRAY(PL_comppad_name);
2933 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2935 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2937 svp[ix] = &PL_sv_undef;
2941 SvREFCNT_dec(CvOUTSIDE(sv));
2942 CvOUTSIDE(sv) = Nullcv;
2955 assert(CvDEPTH(PL_compcv) == 1);
2957 CvDEPTH(PL_compcv) = 0;
2960 if (optype == OP_REQUIRE &&
2961 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2963 /* Unassume the success we assumed earlier. */
2964 char *name = cx->blk_eval.old_name;
2965 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2966 retop = die("%s did not return a true value", name);
2967 /* die_where() did LEAVE, or we won't be here */
2971 if (!(save_flags & OPf_SPECIAL))
2981 register PERL_CONTEXT *cx;
2982 I32 gimme = GIMME_V;
2987 push_return(cLOGOP->op_other->op_next);
2988 PUSHBLOCK(cx, CXt_EVAL, SP);
2990 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2995 return DOCATCH(PL_op->op_next);
3005 register PERL_CONTEXT *cx;
3013 if (gimme == G_VOID)
3015 else if (gimme == G_SCALAR) {
3018 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3021 *MARK = sv_mortalcopy(TOPs);
3025 *MARK = &PL_sv_undef;
3030 /* in case LEAVE wipes old return values */
3031 for (mark = newsp + 1; mark <= SP; mark++) {
3032 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3033 *mark = sv_mortalcopy(*mark);
3034 TAINT_NOT; /* Each item is independent */
3038 PL_curpm = newpm; /* Don't pop $1 et al till now */
3049 register char *s = SvPV_force(sv, len);
3050 register char *send = s + len;
3051 register char *base;
3052 register I32 skipspaces = 0;
3055 bool postspace = FALSE;
3063 croak("Null picture in formline");
3065 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3070 *fpc++ = FF_LINEMARK;
3071 noblank = repeat = FALSE;
3089 case ' ': case '\t':
3100 *fpc++ = FF_LITERAL;
3108 *fpc++ = skipspaces;
3112 *fpc++ = FF_NEWLINE;
3116 arg = fpc - linepc + 1;
3123 *fpc++ = FF_LINEMARK;
3124 noblank = repeat = FALSE;
3133 ischop = s[-1] == '^';
3139 arg = (s - base) - 1;
3141 *fpc++ = FF_LITERAL;
3150 *fpc++ = FF_LINEGLOB;
3152 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3153 arg = ischop ? 512 : 0;
3163 arg |= 256 + (s - f);
3165 *fpc++ = s - base; /* fieldsize for FETCH */
3166 *fpc++ = FF_DECIMAL;
3171 bool ismore = FALSE;
3174 while (*++s == '>') ;
3175 prespace = FF_SPACE;
3177 else if (*s == '|') {
3178 while (*++s == '|') ;
3179 prespace = FF_HALFSPACE;
3184 while (*++s == '<') ;
3187 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3191 *fpc++ = s - base; /* fieldsize for FETCH */
3193 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3211 { /* need to jump to the next word */
3213 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3214 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3215 s = SvPVX(sv) + SvCUR(sv) + z;
3217 Copy(fops, s, arg, U16);
3219 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3224 * The rest of this file was derived from source code contributed
3227 * NOTE: this code was derived from Tom Horsley's qsort replacement
3228 * and should not be confused with the original code.
3231 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3233 Permission granted to distribute under the same terms as perl which are
3236 This program is free software; you can redistribute it and/or modify
3237 it under the terms of either:
3239 a) the GNU General Public License as published by the Free
3240 Software Foundation; either version 1, or (at your option) any
3243 b) the "Artistic License" which comes with this Kit.
3245 Details on the perl license can be found in the perl source code which
3246 may be located via the www.perl.com web page.
3248 This is the most wonderfulest possible qsort I can come up with (and
3249 still be mostly portable) My (limited) tests indicate it consistently
3250 does about 20% fewer calls to compare than does the qsort in the Visual
3251 C++ library, other vendors may vary.
3253 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3254 others I invented myself (or more likely re-invented since they seemed
3255 pretty obvious once I watched the algorithm operate for a while).
3257 Most of this code was written while watching the Marlins sweep the Giants
3258 in the 1997 National League Playoffs - no Braves fans allowed to use this
3259 code (just kidding :-).
3261 I realize that if I wanted to be true to the perl tradition, the only
3262 comment in this file would be something like:
3264 ...they shuffled back towards the rear of the line. 'No, not at the
3265 rear!' the slave-driver shouted. 'Three files up. And stay there...
3267 However, I really needed to violate that tradition just so I could keep
3268 track of what happens myself, not to mention some poor fool trying to
3269 understand this years from now :-).
3272 /* ********************************************************** Configuration */
3274 #ifndef QSORT_ORDER_GUESS
3275 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3278 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3279 future processing - a good max upper bound is log base 2 of memory size
3280 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3281 safely be smaller than that since the program is taking up some space and
3282 most operating systems only let you grab some subset of contiguous
3283 memory (not to mention that you are normally sorting data larger than
3284 1 byte element size :-).
3286 #ifndef QSORT_MAX_STACK
3287 #define QSORT_MAX_STACK 32
3290 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3291 Anything bigger and we use qsort. If you make this too small, the qsort
3292 will probably break (or become less efficient), because it doesn't expect
3293 the middle element of a partition to be the same as the right or left -
3294 you have been warned).
3296 #ifndef QSORT_BREAK_EVEN
3297 #define QSORT_BREAK_EVEN 6
3300 /* ************************************************************* Data Types */
3302 /* hold left and right index values of a partition waiting to be sorted (the
3303 partition includes both left and right - right is NOT one past the end or
3304 anything like that).
3306 struct partition_stack_entry {
3309 #ifdef QSORT_ORDER_GUESS
3310 int qsort_break_even;
3314 /* ******************************************************* Shorthand Macros */
3316 /* Note that these macros will be used from inside the qsort function where
3317 we happen to know that the variable 'elt_size' contains the size of an
3318 array element and the variable 'temp' points to enough space to hold a
3319 temp element and the variable 'array' points to the array being sorted
3320 and 'compare' is the pointer to the compare routine.
3322 Also note that there are very many highly architecture specific ways
3323 these might be sped up, but this is simply the most generally portable
3324 code I could think of.
3327 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3330 #define qsort_cmp(elt1, elt2) \
3331 ((this->*compare)(array[elt1], array[elt2]))
3333 #define qsort_cmp(elt1, elt2) \
3334 ((*compare)(array[elt1], array[elt2]))
3337 #ifdef QSORT_ORDER_GUESS
3338 #define QSORT_NOTICE_SWAP swapped++;
3340 #define QSORT_NOTICE_SWAP
3343 /* swaps contents of array elements elt1, elt2.
3345 #define qsort_swap(elt1, elt2) \
3348 temp = array[elt1]; \
3349 array[elt1] = array[elt2]; \
3350 array[elt2] = temp; \
3353 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3354 elt3 and elt3 gets elt1.
3356 #define qsort_rotate(elt1, elt2, elt3) \
3359 temp = array[elt1]; \
3360 array[elt1] = array[elt2]; \
3361 array[elt2] = array[elt3]; \
3362 array[elt3] = temp; \
3365 /* ************************************************************ Debug stuff */
3372 return; /* good place to set a breakpoint */
3375 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3378 doqsort_all_asserts(
3382 int (*compare)(const void * elt1, const void * elt2),
3383 int pc_left, int pc_right, int u_left, int u_right)
3387 qsort_assert(pc_left <= pc_right);
3388 qsort_assert(u_right < pc_left);
3389 qsort_assert(pc_right < u_left);
3390 for (i = u_right + 1; i < pc_left; ++i) {
3391 qsort_assert(qsort_cmp(i, pc_left) < 0);
3393 for (i = pc_left; i < pc_right; ++i) {
3394 qsort_assert(qsort_cmp(i, pc_right) == 0);
3396 for (i = pc_right + 1; i < u_left; ++i) {
3397 qsort_assert(qsort_cmp(pc_right, i) < 0);
3401 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3402 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3403 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3407 #define qsort_assert(t) ((void)0)
3409 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3413 /* ****************************************************************** qsort */
3417 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3422 I32 (*compare)(SV *a, SV *b))
3427 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3428 int next_stack_entry = 0;
3432 #ifdef QSORT_ORDER_GUESS
3433 int qsort_break_even;
3437 /* Make sure we actually have work to do.
3439 if (num_elts <= 1) {
3443 /* Setup the initial partition definition and fall into the sorting loop
3446 part_right = (int)(num_elts - 1);
3447 #ifdef QSORT_ORDER_GUESS
3448 qsort_break_even = QSORT_BREAK_EVEN;
3450 #define qsort_break_even QSORT_BREAK_EVEN
3453 if ((part_right - part_left) >= qsort_break_even) {
3454 /* OK, this is gonna get hairy, so lets try to document all the
3455 concepts and abbreviations and variables and what they keep
3458 pc: pivot chunk - the set of array elements we accumulate in the
3459 middle of the partition, all equal in value to the original
3460 pivot element selected. The pc is defined by:
3462 pc_left - the leftmost array index of the pc
3463 pc_right - the rightmost array index of the pc
3465 we start with pc_left == pc_right and only one element
3466 in the pivot chunk (but it can grow during the scan).
3468 u: uncompared elements - the set of elements in the partition
3469 we have not yet compared to the pivot value. There are two
3470 uncompared sets during the scan - one to the left of the pc
3471 and one to the right.
3473 u_right - the rightmost index of the left side's uncompared set
3474 u_left - the leftmost index of the right side's uncompared set
3476 The leftmost index of the left sides's uncompared set
3477 doesn't need its own variable because it is always defined
3478 by the leftmost edge of the whole partition (part_left). The
3479 same goes for the rightmost edge of the right partition
3482 We know there are no uncompared elements on the left once we
3483 get u_right < part_left and no uncompared elements on the
3484 right once u_left > part_right. When both these conditions
3485 are met, we have completed the scan of the partition.
3487 Any elements which are between the pivot chunk and the
3488 uncompared elements should be less than the pivot value on
3489 the left side and greater than the pivot value on the right
3490 side (in fact, the goal of the whole algorithm is to arrange
3491 for that to be true and make the groups of less-than and
3492 greater-then elements into new partitions to sort again).
3494 As you marvel at the complexity of the code and wonder why it
3495 has to be so confusing. Consider some of the things this level
3496 of confusion brings:
3498 Once I do a compare, I squeeze every ounce of juice out of it. I
3499 never do compare calls I don't have to do, and I certainly never
3502 I also never swap any elements unless I can prove there is a
3503 good reason. Many sort algorithms will swap a known value with
3504 an uncompared value just to get things in the right place (or
3505 avoid complexity :-), but that uncompared value, once it gets
3506 compared, may then have to be swapped again. A lot of the
3507 complexity of this code is due to the fact that it never swaps
3508 anything except compared values, and it only swaps them when the
3509 compare shows they are out of position.
3511 int pc_left, pc_right;
3512 int u_right, u_left;
3516 pc_left = ((part_left + part_right) / 2);
3518 u_right = pc_left - 1;
3519 u_left = pc_right + 1;
3521 /* Qsort works best when the pivot value is also the median value
3522 in the partition (unfortunately you can't find the median value
3523 without first sorting :-), so to give the algorithm a helping
3524 hand, we pick 3 elements and sort them and use the median value
3525 of that tiny set as the pivot value.
3527 Some versions of qsort like to use the left middle and right as
3528 the 3 elements to sort so they can insure the ends of the
3529 partition will contain values which will stop the scan in the
3530 compare loop, but when you have to call an arbitrarily complex
3531 routine to do a compare, its really better to just keep track of
3532 array index values to know when you hit the edge of the
3533 partition and avoid the extra compare. An even better reason to
3534 avoid using a compare call is the fact that you can drop off the
3535 edge of the array if someone foolishly provides you with an
3536 unstable compare function that doesn't always provide consistent
3539 So, since it is simpler for us to compare the three adjacent
3540 elements in the middle of the partition, those are the ones we
3541 pick here (conveniently pointed at by u_right, pc_left, and
3542 u_left). The values of the left, center, and right elements
3543 are refered to as l c and r in the following comments.
3546 #ifdef QSORT_ORDER_GUESS
3549 s = qsort_cmp(u_right, pc_left);
3552 s = qsort_cmp(pc_left, u_left);
3553 /* if l < c, c < r - already in order - nothing to do */
3555 /* l < c, c == r - already in order, pc grows */
3557 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3559 /* l < c, c > r - need to know more */
3560 s = qsort_cmp(u_right, u_left);
3562 /* l < c, c > r, l < r - swap c & r to get ordered */
3563 qsort_swap(pc_left, u_left);
3564 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3565 } else if (s == 0) {
3566 /* l < c, c > r, l == r - swap c&r, grow pc */
3567 qsort_swap(pc_left, u_left);
3569 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3571 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3572 qsort_rotate(pc_left, u_right, u_left);
3573 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3576 } else if (s == 0) {
3578 s = qsort_cmp(pc_left, u_left);
3580 /* l == c, c < r - already in order, grow pc */
3582 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3583 } else if (s == 0) {
3584 /* l == c, c == r - already in order, grow pc both ways */
3587 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3589 /* l == c, c > r - swap l & r, grow pc */
3590 qsort_swap(u_right, u_left);
3592 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3596 s = qsort_cmp(pc_left, u_left);
3598 /* l > c, c < r - need to know more */
3599 s = qsort_cmp(u_right, u_left);
3601 /* l > c, c < r, l < r - swap l & c to get ordered */
3602 qsort_swap(u_right, pc_left);
3603 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3604 } else if (s == 0) {
3605 /* l > c, c < r, l == r - swap l & c, grow pc */
3606 qsort_swap(u_right, pc_left);
3608 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3610 /* l > c, c < r, l > r - rotate lcr into crl to order */
3611 qsort_rotate(u_right, pc_left, u_left);
3612 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3614 } else if (s == 0) {
3615 /* l > c, c == r - swap ends, grow pc */
3616 qsort_swap(u_right, u_left);
3618 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3620 /* l > c, c > r - swap ends to get in order */
3621 qsort_swap(u_right, u_left);
3622 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3625 /* We now know the 3 middle elements have been compared and
3626 arranged in the desired order, so we can shrink the uncompared
3631 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3633 /* The above massive nested if was the simple part :-). We now have
3634 the middle 3 elements ordered and we need to scan through the
3635 uncompared sets on either side, swapping elements that are on
3636 the wrong side or simply shuffling equal elements around to get
3637 all equal elements into the pivot chunk.
3641 int still_work_on_left;
3642 int still_work_on_right;
3644 /* Scan the uncompared values on the left. If I find a value
3645 equal to the pivot value, move it over so it is adjacent to
3646 the pivot chunk and expand the pivot chunk. If I find a value
3647 less than the pivot value, then just leave it - its already
3648 on the correct side of the partition. If I find a greater
3649 value, then stop the scan.
3651 while (still_work_on_left = (u_right >= part_left)) {
3652 s = qsort_cmp(u_right, pc_left);
3655 } else if (s == 0) {
3657 if (pc_left != u_right) {
3658 qsort_swap(u_right, pc_left);
3664 qsort_assert(u_right < pc_left);
3665 qsort_assert(pc_left <= pc_right);
3666 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3667 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3670 /* Do a mirror image scan of uncompared values on the right
3672 while (still_work_on_right = (u_left <= part_right)) {
3673 s = qsort_cmp(pc_right, u_left);
3676 } else if (s == 0) {
3678 if (pc_right != u_left) {
3679 qsort_swap(pc_right, u_left);
3685 qsort_assert(u_left > pc_right);
3686 qsort_assert(pc_left <= pc_right);
3687 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3688 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3691 if (still_work_on_left) {
3692 /* I know I have a value on the left side which needs to be
3693 on the right side, but I need to know more to decide
3694 exactly the best thing to do with it.
3696 if (still_work_on_right) {
3697 /* I know I have values on both side which are out of
3698 position. This is a big win because I kill two birds
3699 with one swap (so to speak). I can advance the
3700 uncompared pointers on both sides after swapping both
3701 of them into the right place.
3703 qsort_swap(u_right, u_left);
3706 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3708 /* I have an out of position value on the left, but the
3709 right is fully scanned, so I "slide" the pivot chunk
3710 and any less-than values left one to make room for the
3711 greater value over on the right. If the out of position
3712 value is immediately adjacent to the pivot chunk (there
3713 are no less-than values), I can do that with a swap,
3714 otherwise, I have to rotate one of the less than values
3715 into the former position of the out of position value
3716 and the right end of the pivot chunk into the left end
3720 if (pc_left == u_right) {
3721 qsort_swap(u_right, pc_right);
3722 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3724 qsort_rotate(u_right, pc_left, pc_right);
3725 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3730 } else if (still_work_on_right) {
3731 /* Mirror image of complex case above: I have an out of
3732 position value on the right, but the left is fully
3733 scanned, so I need to shuffle things around to make room
3734 for the right value on the left.
3737 if (pc_right == u_left) {
3738 qsort_swap(u_left, pc_left);
3739 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3741 qsort_rotate(pc_right, pc_left, u_left);
3742 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3747 /* No more scanning required on either side of partition,
3748 break out of loop and figure out next set of partitions
3754 /* The elements in the pivot chunk are now in the right place. They
3755 will never move or be compared again. All I have to do is decide
3756 what to do with the stuff to the left and right of the pivot
3759 Notes on the QSORT_ORDER_GUESS ifdef code:
3761 1. If I just built these partitions without swapping any (or
3762 very many) elements, there is a chance that the elements are
3763 already ordered properly (being properly ordered will
3764 certainly result in no swapping, but the converse can't be
3767 2. A (properly written) insertion sort will run faster on
3768 already ordered data than qsort will.
3770 3. Perhaps there is some way to make a good guess about
3771 switching to an insertion sort earlier than partition size 6
3772 (for instance - we could save the partition size on the stack
3773 and increase the size each time we find we didn't swap, thus
3774 switching to insertion sort earlier for partitions with a
3775 history of not swapping).
3777 4. Naturally, if I just switch right away, it will make
3778 artificial benchmarks with pure ascending (or descending)
3779 data look really good, but is that a good reason in general?
3783 #ifdef QSORT_ORDER_GUESS
3785 #if QSORT_ORDER_GUESS == 1
3786 qsort_break_even = (part_right - part_left) + 1;
3788 #if QSORT_ORDER_GUESS == 2
3789 qsort_break_even *= 2;
3791 #if QSORT_ORDER_GUESS == 3
3792 int prev_break = qsort_break_even;
3793 qsort_break_even *= qsort_break_even;
3794 if (qsort_break_even < prev_break) {
3795 qsort_break_even = (part_right - part_left) + 1;
3799 qsort_break_even = QSORT_BREAK_EVEN;
3803 if (part_left < pc_left) {
3804 /* There are elements on the left which need more processing.
3805 Check the right as well before deciding what to do.
3807 if (pc_right < part_right) {
3808 /* We have two partitions to be sorted. Stack the biggest one
3809 and process the smallest one on the next iteration. This
3810 minimizes the stack height by insuring that any additional
3811 stack entries must come from the smallest partition which
3812 (because it is smallest) will have the fewest
3813 opportunities to generate additional stack entries.
3815 if ((part_right - pc_right) > (pc_left - part_left)) {
3816 /* stack the right partition, process the left */
3817 partition_stack[next_stack_entry].left = pc_right + 1;
3818 partition_stack[next_stack_entry].right = part_right;
3819 #ifdef QSORT_ORDER_GUESS
3820 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3822 part_right = pc_left - 1;
3824 /* stack the left partition, process the right */
3825 partition_stack[next_stack_entry].left = part_left;
3826 partition_stack[next_stack_entry].right = pc_left - 1;
3827 #ifdef QSORT_ORDER_GUESS
3828 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3830 part_left = pc_right + 1;
3832 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3835 /* The elements on the left are the only remaining elements
3836 that need sorting, arrange for them to be processed as the
3839 part_right = pc_left - 1;
3841 } else if (pc_right < part_right) {
3842 /* There is only one chunk on the right to be sorted, make it
3843 the new partition and loop back around.
3845 part_left = pc_right + 1;
3847 /* This whole partition wound up in the pivot chunk, so
3848 we need to get a new partition off the stack.
3850 if (next_stack_entry == 0) {
3851 /* the stack is empty - we are done */
3855 part_left = partition_stack[next_stack_entry].left;
3856 part_right = partition_stack[next_stack_entry].right;
3857 #ifdef QSORT_ORDER_GUESS
3858 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3862 /* This partition is too small to fool with qsort complexity, just
3863 do an ordinary insertion sort to minimize overhead.
3866 /* Assume 1st element is in right place already, and start checking
3867 at 2nd element to see where it should be inserted.
3869 for (i = part_left + 1; i <= part_right; ++i) {
3871 /* Scan (backwards - just in case 'i' is already in right place)
3872 through the elements already sorted to see if the ith element
3873 belongs ahead of one of them.
3875 for (j = i - 1; j >= part_left; --j) {
3876 if (qsort_cmp(i, j) >= 0) {
3877 /* i belongs right after j
3884 /* Looks like we really need to move some things
3888 for (k = i - 1; k >= j; --k)
3889 array[k + 1] = array[k];
3894 /* That partition is now sorted, grab the next one, or get out
3895 of the loop if there aren't any more.
3898 if (next_stack_entry == 0) {
3899 /* the stack is empty - we are done */
3903 part_left = partition_stack[next_stack_entry].left;
3904 part_right = partition_stack[next_stack_entry].right;
3905 #ifdef QSORT_ORDER_GUESS
3906 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3911 /* Believe it or not, the array is sorted at this point! */