3 * Copyright (c) 1991-1999, 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.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
30 #define CALLOP this->*PL_op
41 cxix = dopoptosub(cxstack_ix);
45 switch (cxstack[cxix].blk_gimme) {
62 /* XXXX Should store the old value to allow for tie/overload - and
63 restore in regcomp, where marked with XXXX. */
71 register PMOP *pm = (PMOP*)cLOGOP->op_other;
75 MAGIC *mg = Null(MAGIC*);
79 SV *sv = SvRV(tmpstr);
81 mg = mg_find(sv, 'r');
84 regexp *re = (regexp *)mg->mg_obj;
85 ReREFCNT_dec(pm->op_pmregexp);
86 pm->op_pmregexp = ReREFCNT_inc(re);
89 t = SvPV(tmpstr, len);
91 /* Check against the last compiled regexp. */
92 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
93 pm->op_pmregexp->prelen != len ||
94 memNE(pm->op_pmregexp->precomp, t, len))
96 if (pm->op_pmregexp) {
97 ReREFCNT_dec(pm->op_pmregexp);
98 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
100 if (PL_op->op_flags & OPf_SPECIAL)
101 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
103 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
104 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
105 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
106 inside tie/overload accessors. */
110 #ifndef INCOMPLETE_TAINTS
113 pm->op_pmdynflags |= PMdf_TAINTED;
115 pm->op_pmdynflags &= ~PMdf_TAINTED;
119 if (!pm->op_pmregexp->prelen && PL_curpm)
121 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
122 pm->op_pmflags |= PMf_WHITE;
124 if (pm->op_pmflags & PMf_KEEP) {
125 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
126 cLOGOP->op_first->op_next = PL_op->op_next;
134 register PMOP *pm = (PMOP*) cLOGOP->op_other;
135 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
136 register SV *dstr = cx->sb_dstr;
137 register char *s = cx->sb_s;
138 register char *m = cx->sb_m;
139 char *orig = cx->sb_orig;
140 register REGEXP *rx = cx->sb_rx;
142 rxres_restore(&cx->sb_rxres, rx);
144 if (cx->sb_iters++) {
145 if (cx->sb_iters > cx->sb_maxiters)
146 DIE(aTHX_ "Substitution loop");
148 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
149 cx->sb_rxtainted |= 2;
150 sv_catsv(dstr, POPs);
153 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
154 s == m, cx->sb_targ, NULL,
155 ((cx->sb_rflags & REXEC_COPY_STR)
156 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
157 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
159 SV *targ = cx->sb_targ;
160 sv_catpvn(dstr, s, cx->sb_strend - s);
162 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
164 (void)SvOOK_off(targ);
165 Safefree(SvPVX(targ));
166 SvPVX(targ) = SvPVX(dstr);
167 SvCUR_set(targ, SvCUR(dstr));
168 SvLEN_set(targ, SvLEN(dstr));
172 TAINT_IF(cx->sb_rxtainted & 1);
173 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
175 (void)SvPOK_only(targ);
176 TAINT_IF(cx->sb_rxtainted);
180 LEAVE_SCOPE(cx->sb_oldsave);
182 RETURNOP(pm->op_next);
185 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
188 cx->sb_orig = orig = rx->subbeg;
190 cx->sb_strend = s + (cx->sb_strend - m);
192 cx->sb_m = m = rx->startp[0] + orig;
193 sv_catpvn(dstr, s, m-s);
194 cx->sb_s = rx->endp[0] + orig;
195 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
196 rxres_save(&cx->sb_rxres, rx);
197 RETURNOP(pm->op_pmreplstart);
201 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
206 if (!p || p[1] < rx->nparens) {
207 i = 6 + rx->nparens * 2;
215 *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
216 RX_MATCH_COPIED_off(rx);
220 *p++ = (UV)rx->subbeg;
221 *p++ = (UV)rx->sublen;
222 for (i = 0; i <= rx->nparens; ++i) {
223 *p++ = (UV)rx->startp[i];
224 *p++ = (UV)rx->endp[i];
229 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
234 if (RX_MATCH_COPIED(rx))
235 Safefree(rx->subbeg);
236 RX_MATCH_COPIED_set(rx, *p);
241 rx->subbeg = (char*)(*p++);
242 rx->sublen = (I32)(*p++);
243 for (i = 0; i <= rx->nparens; ++i) {
244 rx->startp[i] = (I32)(*p++);
245 rx->endp[i] = (I32)(*p++);
250 Perl_rxres_free(pTHX_ void **rsp)
255 Safefree((char*)(*p));
263 djSP; dMARK; dORIGMARK;
264 register SV *tmpForm = *++MARK;
276 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
282 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
284 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
285 SvREADONLY_off(tmpForm);
286 doparseform(tmpForm);
289 SvPV_force(PL_formtarget, len);
290 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
292 f = SvPV(tmpForm, len);
293 /* need to jump to the next word */
294 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
303 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
304 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
305 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
306 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
307 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
309 case FF_CHECKNL: name = "CHECKNL"; break;
310 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
311 case FF_SPACE: name = "SPACE"; break;
312 case FF_HALFSPACE: name = "HALFSPACE"; break;
313 case FF_ITEM: name = "ITEM"; break;
314 case FF_CHOP: name = "CHOP"; break;
315 case FF_LINEGLOB: name = "LINEGLOB"; break;
316 case FF_NEWLINE: name = "NEWLINE"; break;
317 case FF_MORE: name = "MORE"; break;
318 case FF_LINEMARK: name = "LINEMARK"; break;
319 case FF_END: name = "END"; break;
322 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
324 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
352 if (ckWARN(WARN_SYNTAX))
353 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
358 item = s = SvPV(sv, len);
361 itemsize = sv_len_utf8(sv);
362 if (itemsize != len) {
364 if (itemsize > fieldsize) {
365 itemsize = fieldsize;
366 itembytes = itemsize;
367 sv_pos_u2b(sv, &itembytes, 0);
371 send = chophere = s + itembytes;
380 sv_pos_b2u(sv, &itemsize);
384 if (itemsize > fieldsize)
385 itemsize = fieldsize;
386 send = chophere = s + itemsize;
398 item = s = SvPV(sv, len);
401 itemsize = sv_len_utf8(sv);
402 if (itemsize != len) {
404 if (itemsize <= fieldsize) {
405 send = chophere = s + itemsize;
416 itemsize = fieldsize;
417 itembytes = itemsize;
418 sv_pos_u2b(sv, &itembytes, 0);
419 send = chophere = s + itembytes;
420 while (s < send || (s == send && isSPACE(*s))) {
430 if (strchr(PL_chopset, *s))
435 itemsize = chophere - item;
436 sv_pos_b2u(sv, &itemsize);
441 if (itemsize <= fieldsize) {
442 send = chophere = s + itemsize;
453 itemsize = fieldsize;
454 send = chophere = s + itemsize;
455 while (s < send || (s == send && isSPACE(*s))) {
465 if (strchr(PL_chopset, *s))
470 itemsize = chophere - item;
475 arg = fieldsize - itemsize;
484 arg = fieldsize - itemsize;
499 switch (UTF8SKIP(s)) {
510 if ( !((*t++ = *s++) & ~31) )
518 int ch = *t++ = *s++;
521 if ( !((*t++ = *s++) & ~31) )
530 while (*s && isSPACE(*s))
537 item = s = SvPV(sv, len);
550 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
551 sv_catpvn(PL_formtarget, item, itemsize);
552 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
553 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
558 /* If the field is marked with ^ and the value is undefined,
561 if ((arg & 512) && !SvOK(sv)) {
569 /* Formats aren't yet marked for locales, so assume "yes". */
572 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
574 sprintf(t, "%*.0f", (int) fieldsize, value);
581 while (t-- > linemark && *t == ' ') ;
589 if (arg) { /* repeat until fields exhausted? */
591 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
592 lines += FmLINES(PL_formtarget);
595 if (strnEQ(linemark, linemark - arg, arg))
596 DIE(aTHX_ "Runaway format");
598 FmLINES(PL_formtarget) = lines;
600 RETURNOP(cLISTOP->op_first);
613 while (*s && isSPACE(*s) && s < send)
617 arg = fieldsize - itemsize;
624 if (strnEQ(s," ",3)) {
625 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
636 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
637 FmLINES(PL_formtarget) += lines;
649 if (PL_stack_base + *PL_markstack_ptr == SP) {
651 if (GIMME_V == G_SCALAR)
652 XPUSHs(sv_2mortal(newSViv(0)));
653 RETURNOP(PL_op->op_next->op_next);
655 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
656 pp_pushmark(); /* push dst */
657 pp_pushmark(); /* push src */
658 ENTER; /* enter outer scope */
661 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
663 ENTER; /* enter inner scope */
666 src = PL_stack_base[*PL_markstack_ptr];
671 if (PL_op->op_type == OP_MAPSTART)
672 pp_pushmark(); /* push top */
673 return ((LOGOP*)PL_op->op_next)->op_other;
678 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
684 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
690 ++PL_markstack_ptr[-1];
692 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
693 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
694 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
699 PL_markstack_ptr[-1] += shift;
700 *PL_markstack_ptr += shift;
704 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
707 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
709 LEAVE; /* exit inner scope */
712 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
716 (void)POPMARK; /* pop top */
717 LEAVE; /* exit outer scope */
718 (void)POPMARK; /* pop src */
719 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
720 (void)POPMARK; /* pop dst */
721 SP = PL_stack_base + POPMARK; /* pop original mark */
722 if (gimme == G_SCALAR) {
726 else if (gimme == G_ARRAY)
733 ENTER; /* enter inner scope */
736 src = PL_stack_base[PL_markstack_ptr[-1]];
740 RETURNOP(cLOGOP->op_other);
745 S_sv_ncmp(pTHX_ SV *a, SV *b)
747 double nv1 = SvNV(a);
748 double nv2 = SvNV(b);
749 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
753 S_sv_i_ncmp(pTHX_ SV *a, SV *b)
757 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
759 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
761 if (PL_amagic_generation) { \
762 if (SvAMAGIC(left)||SvAMAGIC(right))\
763 *svp = amagic_call(left, \
771 S_amagic_ncmp(pTHX_ register SV *a, register SV *b)
774 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
779 I32 i = SvIVX(tmpsv);
789 return sv_ncmp(a, b);
793 S_amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
796 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
801 I32 i = SvIVX(tmpsv);
811 return sv_i_ncmp(a, b);
815 S_amagic_cmp(pTHX_ register SV *str1, register SV *str2)
818 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
823 I32 i = SvIVX(tmpsv);
833 return sv_cmp(str1, str2);
837 S_amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
840 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
845 I32 i = SvIVX(tmpsv);
855 return sv_cmp_locale(str1, str2);
860 djSP; dMARK; dORIGMARK;
862 SV **myorigmark = ORIGMARK;
868 OP* nextop = PL_op->op_next;
871 if (gimme != G_ARRAY) {
877 SAVEPPTR(PL_sortcop);
878 if (PL_op->op_flags & OPf_STACKED) {
879 if (PL_op->op_flags & OPf_SPECIAL) {
880 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
881 kid = kUNOP->op_first; /* pass rv2gv */
882 kid = kUNOP->op_first; /* pass leave */
883 PL_sortcop = kid->op_next;
884 stash = PL_curcop->cop_stash;
887 cv = sv_2cv(*++MARK, &stash, &gv, 0);
888 if (!(cv && CvROOT(cv))) {
890 SV *tmpstr = sv_newmortal();
891 gv_efullname3(tmpstr, gv, Nullch);
892 if (cv && CvXSUB(cv))
893 DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
894 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
899 DIE(aTHX_ "Xsub called in sort");
900 DIE(aTHX_ "Undefined subroutine in sort");
902 DIE(aTHX_ "Not a CODE reference in sort");
904 PL_sortcop = CvSTART(cv);
905 SAVESPTR(CvROOT(cv)->op_ppaddr);
906 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
909 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
914 stash = PL_curcop->cop_stash;
918 while (MARK < SP) { /* This may or may not shift down one here. */
920 if (*up = *++MARK) { /* Weed out nulls. */
922 if (!PL_sortcop && !SvPOK(*up)) {
927 (void)sv_2pv(*up, &n_a);
932 max = --up - myorigmark;
937 bool oldcatch = CATCH_GET;
943 PUSHSTACKi(PERLSI_SORT);
944 if (PL_sortstash != stash) {
945 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
946 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
947 PL_sortstash = stash;
950 SAVESPTR(GvSV(PL_firstgv));
951 SAVESPTR(GvSV(PL_secondgv));
953 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
954 if (!(PL_op->op_flags & OPf_SPECIAL)) {
955 bool hasargs = FALSE;
956 cx->cx_type = CXt_SUB;
957 cx->blk_gimme = G_SCALAR;
960 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
962 PL_sortcxix = cxstack_ix;
963 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(S_sortcv));
965 POPBLOCK(cx,PL_curpm);
973 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
974 qsortsv(ORIGMARK+1, max,
975 (PL_op->op_private & OPpSORT_NUMERIC)
976 ? ( (PL_op->op_private & OPpSORT_INTEGER)
978 ? FUNC_NAME_TO_PTR(S_amagic_i_ncmp)
979 : FUNC_NAME_TO_PTR(S_sv_i_ncmp))
981 ? FUNC_NAME_TO_PTR(S_amagic_ncmp)
982 : FUNC_NAME_TO_PTR(S_sv_ncmp)))
983 : ( (PL_op->op_private & OPpLOCALE)
985 ? FUNC_NAME_TO_PTR(S_amagic_cmp_locale)
986 : FUNC_NAME_TO_PTR(Perl_sv_cmp_locale))
988 ? FUNC_NAME_TO_PTR(S_amagic_cmp)
989 : FUNC_NAME_TO_PTR(Perl_sv_cmp) )));
990 if (PL_op->op_private & OPpSORT_REVERSE) {
992 SV **q = ORIGMARK+max;
1002 PL_stack_sp = ORIGMARK + max;
1010 if (GIMME == G_ARRAY)
1011 return cCONDOP->op_true;
1012 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1013 return cCONDOP->op_false;
1015 return cCONDOP->op_true;
1022 if (GIMME == G_ARRAY) {
1023 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1027 SV *targ = PAD_SV(PL_op->op_targ);
1029 if ((PL_op->op_private & OPpFLIP_LINENUM)
1030 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1032 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1033 if (PL_op->op_flags & OPf_SPECIAL) {
1041 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1054 if (GIMME == G_ARRAY) {
1060 if (SvGMAGICAL(left))
1062 if (SvGMAGICAL(right))
1065 if (SvNIOKp(left) || !SvPOKp(left) ||
1066 (looks_like_number(left) && *SvPVX(left) != '0') )
1068 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1069 Perl_croak(aTHX_ "Range iterator outside integer range");
1080 sv = sv_2mortal(newSViv(i++));
1085 SV *final = sv_mortalcopy(right);
1087 char *tmps = SvPV(final, len);
1089 sv = sv_mortalcopy(left);
1091 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1093 if (strEQ(SvPVX(sv),tmps))
1095 sv = sv_2mortal(newSVsv(sv));
1102 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1104 if ((PL_op->op_private & OPpFLIP_LINENUM)
1105 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1107 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1108 sv_catpv(targ, "E0");
1119 S_dopoptolabel(pTHX_ char *label)
1123 register PERL_CONTEXT *cx;
1125 for (i = cxstack_ix; i >= 0; i--) {
1127 switch (CxTYPE(cx)) {
1129 if (ckWARN(WARN_UNSAFE))
1130 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1131 PL_op_name[PL_op->op_type]);
1134 if (ckWARN(WARN_UNSAFE))
1135 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1136 PL_op_name[PL_op->op_type]);
1139 if (ckWARN(WARN_UNSAFE))
1140 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1141 PL_op_name[PL_op->op_type]);
1144 if (ckWARN(WARN_UNSAFE))
1145 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1146 PL_op_name[PL_op->op_type]);
1149 if (!cx->blk_loop.label ||
1150 strNE(label, cx->blk_loop.label) ) {
1151 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1152 (long)i, cx->blk_loop.label));
1155 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1163 Perl_dowantarray(pTHX)
1165 I32 gimme = block_gimme();
1166 return (gimme == G_VOID) ? G_SCALAR : gimme;
1170 Perl_block_gimme(pTHX)
1175 cxix = dopoptosub(cxstack_ix);
1179 switch (cxstack[cxix].blk_gimme) {
1187 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1194 S_dopoptosub(pTHX_ I32 startingblock)
1197 return dopoptosub_at(cxstack, startingblock);
1201 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1205 register PERL_CONTEXT *cx;
1206 for (i = startingblock; i >= 0; i--) {
1208 switch (CxTYPE(cx)) {
1213 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1221 S_dopoptoeval(pTHX_ I32 startingblock)
1225 register PERL_CONTEXT *cx;
1226 for (i = startingblock; i >= 0; i--) {
1228 switch (CxTYPE(cx)) {
1232 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1240 S_dopoptoloop(pTHX_ I32 startingblock)
1244 register PERL_CONTEXT *cx;
1245 for (i = startingblock; i >= 0; i--) {
1247 switch (CxTYPE(cx)) {
1249 if (ckWARN(WARN_UNSAFE))
1250 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1251 PL_op_name[PL_op->op_type]);
1254 if (ckWARN(WARN_UNSAFE))
1255 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1256 PL_op_name[PL_op->op_type]);
1259 if (ckWARN(WARN_UNSAFE))
1260 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1261 PL_op_name[PL_op->op_type]);
1264 if (ckWARN(WARN_UNSAFE))
1265 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1266 PL_op_name[PL_op->op_type]);
1269 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1277 Perl_dounwind(pTHX_ I32 cxix)
1280 register PERL_CONTEXT *cx;
1284 while (cxstack_ix > cxix) {
1285 cx = &cxstack[cxstack_ix];
1286 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1287 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1288 /* Note: we don't need to restore the base context info till the end. */
1289 switch (CxTYPE(cx)) {
1292 continue; /* not break */
1310 * Closures mentioned at top level of eval cannot be referenced
1311 * again, and their presence indirectly causes a memory leak.
1312 * (Note that the fact that compcv and friends are still set here
1313 * is, AFAIK, an accident.) --Chip
1315 * XXX need to get comppad et al from eval's cv rather than
1316 * relying on the incidental global values.
1319 S_free_closures(pTHX)
1322 SV **svp = AvARRAY(PL_comppad_name);
1324 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1326 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1328 svp[ix] = &PL_sv_undef;
1332 SvREFCNT_dec(CvOUTSIDE(sv));
1333 CvOUTSIDE(sv) = Nullcv;
1346 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1352 register PERL_CONTEXT *cx;
1357 if (PL_in_eval & EVAL_KEEPERR) {
1360 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1363 static char prefix[] = "\t(in cleanup) ";
1365 sv_upgrade(*svp, SVt_IV);
1366 (void)SvIOK_only(*svp);
1369 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1370 sv_catpvn(err, prefix, sizeof(prefix)-1);
1371 sv_catpvn(err, message, msglen);
1372 if (ckWARN(WARN_UNSAFE)) {
1373 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1374 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1381 sv_setpvn(ERRSV, message, msglen);
1384 message = SvPVx(ERRSV, msglen);
1386 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1394 if (cxix < cxstack_ix)
1397 POPBLOCK(cx,PL_curpm);
1398 if (CxTYPE(cx) != CXt_EVAL) {
1399 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1400 PerlIO_write(PerlIO_stderr(), message, msglen);
1405 if (gimme == G_SCALAR)
1406 *++newsp = &PL_sv_undef;
1407 PL_stack_sp = newsp;
1411 if (optype == OP_REQUIRE) {
1412 char* msg = SvPVx(ERRSV, n_a);
1413 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
1415 return pop_return();
1419 message = SvPVx(ERRSV, msglen);
1422 /* SFIO can really mess with your errno */
1425 PerlIO_write(PerlIO_stderr(), message, msglen);
1426 (void)PerlIO_flush(PerlIO_stderr());
1439 if (SvTRUE(left) != SvTRUE(right))
1451 RETURNOP(cLOGOP->op_other);
1460 RETURNOP(cLOGOP->op_other);
1466 register I32 cxix = dopoptosub(cxstack_ix);
1467 register PERL_CONTEXT *cx;
1468 register PERL_CONTEXT *ccstack = cxstack;
1469 PERL_SI *top_si = PL_curstackinfo;
1480 /* we may be in a higher stacklevel, so dig down deeper */
1481 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1482 top_si = top_si->si_prev;
1483 ccstack = top_si->si_cxstack;
1484 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1487 if (GIMME != G_ARRAY)
1491 if (PL_DBsub && cxix >= 0 &&
1492 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1496 cxix = dopoptosub_at(ccstack, cxix - 1);
1499 cx = &ccstack[cxix];
1500 if (CxTYPE(cx) == CXt_SUB) {
1501 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1502 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1503 field below is defined for any cx. */
1504 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1505 cx = &ccstack[dbcxix];
1508 if (GIMME != G_ARRAY) {
1509 hv = cx->blk_oldcop->cop_stash;
1511 PUSHs(&PL_sv_undef);
1514 sv_setpv(TARG, HvNAME(hv));
1520 hv = cx->blk_oldcop->cop_stash;
1522 PUSHs(&PL_sv_undef);
1524 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1525 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1526 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1527 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1530 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1532 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1533 PUSHs(sv_2mortal(sv));
1534 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1537 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1538 PUSHs(sv_2mortal(newSViv(0)));
1540 gimme = (I32)cx->blk_gimme;
1541 if (gimme == G_VOID)
1542 PUSHs(&PL_sv_undef);
1544 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1545 if (CxTYPE(cx) == CXt_EVAL) {
1546 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1547 PUSHs(cx->blk_eval.cur_text);
1550 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1551 /* Require, put the name. */
1552 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1556 else if (CxTYPE(cx) == CXt_SUB &&
1557 cx->blk_sub.hasargs &&
1558 PL_curcop->cop_stash == PL_debstash)
1560 AV *ary = cx->blk_sub.argarray;
1561 int off = AvARRAY(ary) - AvALLOC(ary);
1565 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1568 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1571 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1572 av_extend(PL_dbargs, AvFILLp(ary) + off);
1573 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1574 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1580 S_sortcv(pTHX_ SV *a, SV *b)
1583 I32 oldsaveix = PL_savestack_ix;
1584 I32 oldscopeix = PL_scopestack_ix;
1586 GvSV(PL_firstgv) = a;
1587 GvSV(PL_secondgv) = b;
1588 PL_stack_sp = PL_stack_base;
1591 if (PL_stack_sp != PL_stack_base + 1)
1592 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1593 if (!SvNIOKp(*PL_stack_sp))
1594 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1595 result = SvIV(*PL_stack_sp);
1596 while (PL_scopestack_ix > oldscopeix) {
1599 leave_scope(oldsaveix);
1613 sv_reset(tmps, PL_curcop->cop_stash);
1625 PL_curcop = (COP*)PL_op;
1626 TAINT_NOT; /* Each statement is presumed innocent */
1627 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1630 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1634 register PERL_CONTEXT *cx;
1635 I32 gimme = G_ARRAY;
1642 DIE(aTHX_ "No DB::DB routine defined");
1644 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1656 push_return(PL_op->op_next);
1657 PUSHBLOCK(cx, CXt_SUB, SP);
1660 (void)SvREFCNT_inc(cv);
1661 SAVESPTR(PL_curpad);
1662 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1663 RETURNOP(CvSTART(cv));
1677 register PERL_CONTEXT *cx;
1678 I32 gimme = GIMME_V;
1685 if (PL_op->op_flags & OPf_SPECIAL) {
1687 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1688 SAVEGENERICSV(*svp);
1692 #endif /* USE_THREADS */
1693 if (PL_op->op_targ) {
1694 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1698 svp = &GvSV((GV*)POPs); /* symbol table variable */
1699 SAVEGENERICSV(*svp);
1705 PUSHBLOCK(cx, CXt_LOOP, SP);
1706 PUSHLOOP(cx, svp, MARK);
1707 if (PL_op->op_flags & OPf_STACKED) {
1708 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1709 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1711 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1712 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1713 if (SvNV(sv) < IV_MIN ||
1714 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1715 Perl_croak(aTHX_ "Range iterator outside integer range");
1716 cx->blk_loop.iterix = SvIV(sv);
1717 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1720 cx->blk_loop.iterlval = newSVsv(sv);
1724 cx->blk_loop.iterary = PL_curstack;
1725 AvFILLp(PL_curstack) = SP - PL_stack_base;
1726 cx->blk_loop.iterix = MARK - PL_stack_base;
1735 register PERL_CONTEXT *cx;
1736 I32 gimme = GIMME_V;
1742 PUSHBLOCK(cx, CXt_LOOP, SP);
1743 PUSHLOOP(cx, 0, SP);
1751 register PERL_CONTEXT *cx;
1752 struct block_loop cxloop;
1760 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1763 if (gimme == G_VOID)
1765 else if (gimme == G_SCALAR) {
1767 *++newsp = sv_mortalcopy(*SP);
1769 *++newsp = &PL_sv_undef;
1773 *++newsp = sv_mortalcopy(*++mark);
1774 TAINT_NOT; /* Each item is independent */
1780 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1781 PL_curpm = newpm; /* ... and pop $1 et al */
1793 register PERL_CONTEXT *cx;
1794 struct block_sub cxsub;
1795 bool popsub2 = FALSE;
1801 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1802 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1803 if (cxstack_ix > PL_sortcxix)
1804 dounwind(PL_sortcxix);
1805 AvARRAY(PL_curstack)[1] = *SP;
1806 PL_stack_sp = PL_stack_base + 1;
1811 cxix = dopoptosub(cxstack_ix);
1813 DIE(aTHX_ "Can't return outside a subroutine");
1814 if (cxix < cxstack_ix)
1818 switch (CxTYPE(cx)) {
1820 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1825 if (AvFILLp(PL_comppad_name) >= 0)
1828 if (optype == OP_REQUIRE &&
1829 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1831 /* Unassume the success we assumed earlier. */
1832 char *name = cx->blk_eval.old_name;
1833 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1834 DIE(aTHX_ "%s did not return a true value", name);
1838 DIE(aTHX_ "panic: return");
1842 if (gimme == G_SCALAR) {
1845 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1847 *++newsp = SvREFCNT_inc(*SP);
1852 *++newsp = sv_mortalcopy(*SP);
1855 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1857 *++newsp = sv_mortalcopy(*SP);
1859 *++newsp = &PL_sv_undef;
1861 else if (gimme == G_ARRAY) {
1862 while (++MARK <= SP) {
1863 *++newsp = (popsub2 && SvTEMP(*MARK))
1864 ? *MARK : sv_mortalcopy(*MARK);
1865 TAINT_NOT; /* Each item is independent */
1868 PL_stack_sp = newsp;
1870 /* Stack values are safe: */
1872 POPSUB2(); /* release CV and @_ ... */
1874 PL_curpm = newpm; /* ... and pop $1 et al */
1877 return pop_return();
1884 register PERL_CONTEXT *cx;
1885 struct block_loop cxloop;
1886 struct block_sub cxsub;
1893 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1895 if (PL_op->op_flags & OPf_SPECIAL) {
1896 cxix = dopoptoloop(cxstack_ix);
1898 DIE(aTHX_ "Can't \"last\" outside a block");
1901 cxix = dopoptolabel(cPVOP->op_pv);
1903 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1905 if (cxix < cxstack_ix)
1909 switch (CxTYPE(cx)) {
1911 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1913 nextop = cxloop.last_op->op_next;
1916 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1918 nextop = pop_return();
1922 nextop = pop_return();
1925 DIE(aTHX_ "panic: last");
1929 if (gimme == G_SCALAR) {
1931 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1932 ? *SP : sv_mortalcopy(*SP);
1934 *++newsp = &PL_sv_undef;
1936 else if (gimme == G_ARRAY) {
1937 while (++MARK <= SP) {
1938 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1939 ? *MARK : sv_mortalcopy(*MARK);
1940 TAINT_NOT; /* Each item is independent */
1946 /* Stack values are safe: */
1949 POPLOOP2(); /* release loop vars ... */
1953 POPSUB2(); /* release CV and @_ ... */
1956 PL_curpm = newpm; /* ... and pop $1 et al */
1965 register PERL_CONTEXT *cx;
1968 if (PL_op->op_flags & OPf_SPECIAL) {
1969 cxix = dopoptoloop(cxstack_ix);
1971 DIE(aTHX_ "Can't \"next\" outside a block");
1974 cxix = dopoptolabel(cPVOP->op_pv);
1976 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1978 if (cxix < cxstack_ix)
1982 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1983 LEAVE_SCOPE(oldsave);
1984 return cx->blk_loop.next_op;
1990 register PERL_CONTEXT *cx;
1993 if (PL_op->op_flags & OPf_SPECIAL) {
1994 cxix = dopoptoloop(cxstack_ix);
1996 DIE(aTHX_ "Can't \"redo\" outside a block");
1999 cxix = dopoptolabel(cPVOP->op_pv);
2001 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2003 if (cxix < cxstack_ix)
2007 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2008 LEAVE_SCOPE(oldsave);
2009 return cx->blk_loop.redo_op;
2013 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2017 static char too_deep[] = "Target of goto is too deeply nested";
2020 Perl_croak(aTHX_ too_deep);
2021 if (o->op_type == OP_LEAVE ||
2022 o->op_type == OP_SCOPE ||
2023 o->op_type == OP_LEAVELOOP ||
2024 o->op_type == OP_LEAVETRY)
2026 *ops++ = cUNOPo->op_first;
2028 Perl_croak(aTHX_ too_deep);
2031 if (o->op_flags & OPf_KIDS) {
2033 /* First try all the kids at this level, since that's likeliest. */
2034 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2035 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2036 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2039 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2040 if (kid == PL_lastgotoprobe)
2042 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2044 (ops[-1]->op_type != OP_NEXTSTATE &&
2045 ops[-1]->op_type != OP_DBSTATE)))
2047 if (o = dofindlabel(kid, label, ops, oplimit))
2066 register PERL_CONTEXT *cx;
2067 #define GOTO_DEPTH 64
2068 OP *enterops[GOTO_DEPTH];
2070 int do_dump = (PL_op->op_type == OP_DUMP);
2071 static char must_have_label[] = "goto must have label";
2074 if (PL_op->op_flags & OPf_STACKED) {
2078 /* This egregious kludge implements goto &subroutine */
2079 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2081 register PERL_CONTEXT *cx;
2082 CV* cv = (CV*)SvRV(sv);
2086 int arg_was_real = 0;
2089 if (!CvROOT(cv) && !CvXSUB(cv)) {
2094 /* autoloaded stub? */
2095 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2097 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2098 GvNAMELEN(gv), FALSE);
2099 if (autogv && (cv = GvCV(autogv)))
2101 tmpstr = sv_newmortal();
2102 gv_efullname3(tmpstr, gv, Nullch);
2103 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2105 DIE(aTHX_ "Goto undefined subroutine");
2108 /* First do some returnish stuff. */
2109 cxix = dopoptosub(cxstack_ix);
2111 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2112 if (cxix < cxstack_ix)
2115 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2116 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2118 if (CxTYPE(cx) == CXt_SUB &&
2119 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2120 AV* av = cx->blk_sub.argarray;
2122 items = AvFILLp(av) + 1;
2124 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2125 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2126 PL_stack_sp += items;
2128 SvREFCNT_dec(GvAV(PL_defgv));
2129 GvAV(PL_defgv) = cx->blk_sub.savearray;
2130 #endif /* USE_THREADS */
2133 AvREAL_off(av); /* so av_clear() won't clobber elts */
2137 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2141 av = (AV*)PL_curpad[0];
2143 av = GvAV(PL_defgv);
2145 items = AvFILLp(av) + 1;
2147 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2148 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2149 PL_stack_sp += items;
2151 if (CxTYPE(cx) == CXt_SUB &&
2152 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2153 SvREFCNT_dec(cx->blk_sub.cv);
2154 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2155 LEAVE_SCOPE(oldsave);
2157 /* Now do some callish stuff. */
2160 #ifdef PERL_XSUB_OLDSTYLE
2161 if (CvOLDSTYLE(cv)) {
2162 I32 (*fp3)(int,int,int);
2167 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2168 items = (*fp3)(CvXSUBANY(cv).any_i32,
2169 mark - PL_stack_base + 1,
2171 SP = PL_stack_base + items;
2174 #endif /* PERL_XSUB_OLDSTYLE */
2179 PL_stack_sp--; /* There is no cv arg. */
2180 /* Push a mark for the start of arglist */
2182 (void)(*CvXSUB(cv))(aTHX_ cv);
2183 /* Pop the current context like a decent sub should */
2184 POPBLOCK(cx, PL_curpm);
2185 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2188 return pop_return();
2191 AV* padlist = CvPADLIST(cv);
2192 SV** svp = AvARRAY(padlist);
2193 if (CxTYPE(cx) == CXt_EVAL) {
2194 PL_in_eval = cx->blk_eval.old_in_eval;
2195 PL_eval_root = cx->blk_eval.old_eval_root;
2196 cx->cx_type = CXt_SUB;
2197 cx->blk_sub.hasargs = 0;
2199 cx->blk_sub.cv = cv;
2200 cx->blk_sub.olddepth = CvDEPTH(cv);
2202 if (CvDEPTH(cv) < 2)
2203 (void)SvREFCNT_inc(cv);
2204 else { /* save temporaries on recursion? */
2205 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2206 sub_crush_depth(cv);
2207 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2208 AV *newpad = newAV();
2209 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2210 I32 ix = AvFILLp((AV*)svp[1]);
2211 svp = AvARRAY(svp[0]);
2212 for ( ;ix > 0; ix--) {
2213 if (svp[ix] != &PL_sv_undef) {
2214 char *name = SvPVX(svp[ix]);
2215 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2218 /* outer lexical or anon code */
2219 av_store(newpad, ix,
2220 SvREFCNT_inc(oldpad[ix]) );
2222 else { /* our own lexical */
2224 av_store(newpad, ix, sv = (SV*)newAV());
2225 else if (*name == '%')
2226 av_store(newpad, ix, sv = (SV*)newHV());
2228 av_store(newpad, ix, sv = NEWSV(0,0));
2233 av_store(newpad, ix, sv = NEWSV(0,0));
2237 if (cx->blk_sub.hasargs) {
2240 av_store(newpad, 0, (SV*)av);
2241 AvFLAGS(av) = AVf_REIFY;
2243 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2244 AvFILLp(padlist) = CvDEPTH(cv);
2245 svp = AvARRAY(padlist);
2249 if (!cx->blk_sub.hasargs) {
2250 AV* av = (AV*)PL_curpad[0];
2252 items = AvFILLp(av) + 1;
2254 /* Mark is at the end of the stack. */
2256 Copy(AvARRAY(av), SP + 1, items, SV*);
2261 #endif /* USE_THREADS */
2262 SAVESPTR(PL_curpad);
2263 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2265 if (cx->blk_sub.hasargs)
2266 #endif /* USE_THREADS */
2268 AV* av = (AV*)PL_curpad[0];
2272 cx->blk_sub.savearray = GvAV(PL_defgv);
2273 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2274 #endif /* USE_THREADS */
2275 cx->blk_sub.argarray = av;
2278 if (items >= AvMAX(av) + 1) {
2280 if (AvARRAY(av) != ary) {
2281 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2282 SvPVX(av) = (char*)ary;
2284 if (items >= AvMAX(av) + 1) {
2285 AvMAX(av) = items - 1;
2286 Renew(ary,items+1,SV*);
2288 SvPVX(av) = (char*)ary;
2291 Copy(mark,AvARRAY(av),items,SV*);
2292 AvFILLp(av) = items - 1;
2293 /* preserve @_ nature */
2304 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2306 * We do not care about using sv to call CV;
2307 * it's for informational purposes only.
2309 SV *sv = GvSV(PL_DBsub);
2312 if (PERLDB_SUB_NN) {
2313 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2316 gv_efullname3(sv, CvGV(cv), Nullch);
2319 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2320 PUSHMARK( PL_stack_sp );
2321 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2325 RETURNOP(CvSTART(cv));
2329 label = SvPV(sv,n_a);
2330 if (!(do_dump || *label))
2331 DIE(aTHX_ must_have_label);
2334 else if (PL_op->op_flags & OPf_SPECIAL) {
2336 DIE(aTHX_ must_have_label);
2339 label = cPVOP->op_pv;
2341 if (label && *label) {
2346 PL_lastgotoprobe = 0;
2348 for (ix = cxstack_ix; ix >= 0; ix--) {
2350 switch (CxTYPE(cx)) {
2352 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2355 gotoprobe = cx->blk_oldcop->op_sibling;
2361 gotoprobe = cx->blk_oldcop->op_sibling;
2363 gotoprobe = PL_main_root;
2366 if (CvDEPTH(cx->blk_sub.cv)) {
2367 gotoprobe = CvROOT(cx->blk_sub.cv);
2372 DIE(aTHX_ "Can't \"goto\" outside a block");
2375 DIE(aTHX_ "panic: goto");
2376 gotoprobe = PL_main_root;
2379 retop = dofindlabel(gotoprobe, label,
2380 enterops, enterops + GOTO_DEPTH);
2383 PL_lastgotoprobe = gotoprobe;
2386 DIE(aTHX_ "Can't find label %s", label);
2388 /* pop unwanted frames */
2390 if (ix < cxstack_ix) {
2397 oldsave = PL_scopestack[PL_scopestack_ix];
2398 LEAVE_SCOPE(oldsave);
2401 /* push wanted frames */
2403 if (*enterops && enterops[1]) {
2405 for (ix = 1; enterops[ix]; ix++) {
2406 PL_op = enterops[ix];
2407 /* Eventually we may want to stack the needed arguments
2408 * for each op. For now, we punt on the hard ones. */
2409 if (PL_op->op_type == OP_ENTERITER)
2410 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2412 (CALLOP->op_ppaddr)(aTHX);
2420 if (!retop) retop = PL_main_start;
2422 PL_restartop = retop;
2423 PL_do_undump = TRUE;
2427 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2428 PL_do_undump = FALSE;
2444 if (anum == 1 && VMSISH_EXIT)
2449 PUSHs(&PL_sv_undef);
2457 double value = SvNVx(GvSV(cCOP->cop_gv));
2458 register I32 match = I_32(value);
2461 if (((double)match) > value)
2462 --match; /* was fractional--truncate other way */
2464 match -= cCOP->uop.scop.scop_offset;
2467 else if (match > cCOP->uop.scop.scop_max)
2468 match = cCOP->uop.scop.scop_max;
2469 PL_op = cCOP->uop.scop.scop_next[match];
2479 PL_op = PL_op->op_next; /* can't assume anything */
2482 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2483 match -= cCOP->uop.scop.scop_offset;
2486 else if (match > cCOP->uop.scop.scop_max)
2487 match = cCOP->uop.scop.scop_max;
2488 PL_op = cCOP->uop.scop.scop_next[match];
2497 S_save_lines(pTHX_ AV *array, SV *sv)
2499 register char *s = SvPVX(sv);
2500 register char *send = SvPVX(sv) + SvCUR(sv);
2502 register I32 line = 1;
2504 while (s && s < send) {
2505 SV *tmpstr = NEWSV(85,0);
2507 sv_upgrade(tmpstr, SVt_PVMG);
2508 t = strchr(s, '\n');
2514 sv_setpvn(tmpstr, s, t - s);
2515 av_store(array, line++, tmpstr);
2521 S_docatch_body(pTHX_ va_list args)
2528 S_docatch(pTHX_ OP *o)
2535 assert(CATCH_GET == TRUE);
2539 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_docatch_body));
2545 PL_op = PL_restartop;
2560 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2561 /* sv Text to convert to OP tree. */
2562 /* startop op_free() this to undo. */
2563 /* code Short string id of the caller. */
2565 dSP; /* Make POPBLOCK work. */
2568 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2571 OP *oop = PL_op, *rop;
2572 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2578 /* switch to eval mode */
2580 if (PL_curcop == &PL_compiling) {
2581 SAVESPTR(PL_compiling.cop_stash);
2582 PL_compiling.cop_stash = PL_curstash;
2584 SAVESPTR(PL_compiling.cop_filegv);
2585 SAVEI16(PL_compiling.cop_line);
2586 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2587 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2588 PL_compiling.cop_line = 1;
2589 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2590 deleting the eval's FILEGV from the stash before gv_check() runs
2591 (i.e. before run-time proper). To work around the coredump that
2592 ensues, we always turn GvMULTI_on for any globals that were
2593 introduced within evals. See force_ident(). GSAR 96-10-12 */
2594 safestr = savepv(tmpbuf);
2595 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2597 #ifdef OP_IN_REGISTER
2605 PL_op->op_type = OP_ENTEREVAL;
2606 PL_op->op_flags = 0; /* Avoid uninit warning. */
2607 PUSHBLOCK(cx, CXt_EVAL, SP);
2608 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2609 rop = doeval(G_SCALAR, startop);
2610 POPBLOCK(cx,PL_curpm);
2613 (*startop)->op_type = OP_NULL;
2614 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2616 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2618 if (PL_curcop == &PL_compiling)
2619 PL_compiling.op_private = PL_hints;
2620 #ifdef OP_IN_REGISTER
2626 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2628 S_doeval(pTHX_ int gimme, OP** startop)
2637 PL_in_eval = EVAL_INEVAL;
2641 /* set up a scratch pad */
2644 SAVESPTR(PL_curpad);
2645 SAVESPTR(PL_comppad);
2646 SAVESPTR(PL_comppad_name);
2647 SAVEI32(PL_comppad_name_fill);
2648 SAVEI32(PL_min_intro_pending);
2649 SAVEI32(PL_max_intro_pending);
2652 for (i = cxstack_ix - 1; i >= 0; i--) {
2653 PERL_CONTEXT *cx = &cxstack[i];
2654 if (CxTYPE(cx) == CXt_EVAL)
2656 else if (CxTYPE(cx) == CXt_SUB) {
2657 caller = cx->blk_sub.cv;
2662 SAVESPTR(PL_compcv);
2663 PL_compcv = (CV*)NEWSV(1104,0);
2664 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2665 CvEVAL_on(PL_compcv);
2667 CvOWNER(PL_compcv) = 0;
2668 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2669 MUTEX_INIT(CvMUTEXP(PL_compcv));
2670 #endif /* USE_THREADS */
2672 PL_comppad = newAV();
2673 av_push(PL_comppad, Nullsv);
2674 PL_curpad = AvARRAY(PL_comppad);
2675 PL_comppad_name = newAV();
2676 PL_comppad_name_fill = 0;
2677 PL_min_intro_pending = 0;
2680 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2681 PL_curpad[0] = (SV*)newAV();
2682 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2683 #endif /* USE_THREADS */
2685 comppadlist = newAV();
2686 AvREAL_off(comppadlist);
2687 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2688 av_store(comppadlist, 1, (SV*)PL_comppad);
2689 CvPADLIST(PL_compcv) = comppadlist;
2691 if (!saveop || saveop->op_type != OP_REQUIRE)
2692 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2694 SAVEFREESV(PL_compcv);
2696 /* make sure we compile in the right package */
2698 newstash = PL_curcop->cop_stash;
2699 if (PL_curstash != newstash) {
2700 SAVESPTR(PL_curstash);
2701 PL_curstash = newstash;
2703 SAVESPTR(PL_beginav);
2704 PL_beginav = newAV();
2705 SAVEFREESV(PL_beginav);
2707 /* try to compile it */
2709 PL_eval_root = Nullop;
2711 PL_curcop = &PL_compiling;
2712 PL_curcop->cop_arybase = 0;
2713 SvREFCNT_dec(PL_rs);
2714 PL_rs = newSVpvn("\n", 1);
2715 if (saveop && saveop->op_flags & OPf_SPECIAL)
2716 PL_in_eval |= EVAL_KEEPERR;
2719 if (yyparse() || PL_error_count || !PL_eval_root) {
2723 I32 optype = 0; /* Might be reset by POPEVAL. */
2728 op_free(PL_eval_root);
2729 PL_eval_root = Nullop;
2731 SP = PL_stack_base + POPMARK; /* pop original mark */
2733 POPBLOCK(cx,PL_curpm);
2739 if (optype == OP_REQUIRE) {
2740 char* msg = SvPVx(ERRSV, n_a);
2741 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
2742 } else if (startop) {
2743 char* msg = SvPVx(ERRSV, n_a);
2745 POPBLOCK(cx,PL_curpm);
2747 Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2749 SvREFCNT_dec(PL_rs);
2750 PL_rs = SvREFCNT_inc(PL_nrs);
2752 MUTEX_LOCK(&PL_eval_mutex);
2754 COND_SIGNAL(&PL_eval_cond);
2755 MUTEX_UNLOCK(&PL_eval_mutex);
2756 #endif /* USE_THREADS */
2759 SvREFCNT_dec(PL_rs);
2760 PL_rs = SvREFCNT_inc(PL_nrs);
2761 PL_compiling.cop_line = 0;
2763 *startop = PL_eval_root;
2764 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2765 CvOUTSIDE(PL_compcv) = Nullcv;
2767 SAVEFREEOP(PL_eval_root);
2769 scalarvoid(PL_eval_root);
2770 else if (gimme & G_ARRAY)
2773 scalar(PL_eval_root);
2775 DEBUG_x(dump_eval());
2777 /* Register with debugger: */
2778 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2779 CV *cv = get_cv("DB::postponed", FALSE);
2783 XPUSHs((SV*)PL_compiling.cop_filegv);
2785 call_sv((SV*)cv, G_DISCARD);
2789 /* compiled okay, so do it */
2791 CvDEPTH(PL_compcv) = 1;
2792 SP = PL_stack_base + POPMARK; /* pop original mark */
2793 PL_op = saveop; /* The caller may need it. */
2795 MUTEX_LOCK(&PL_eval_mutex);
2797 COND_SIGNAL(&PL_eval_cond);
2798 MUTEX_UNLOCK(&PL_eval_mutex);
2799 #endif /* USE_THREADS */
2801 RETURNOP(PL_eval_start);
2805 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2807 STRLEN namelen = strlen(name);
2810 if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
2811 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2812 char *pmc = SvPV_nolen(pmcsv);
2815 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2816 fp = PerlIO_open(name, mode);
2819 if (PerlLIO_stat(name, &pmstat) < 0 ||
2820 pmstat.st_mtime < pmcstat.st_mtime)
2822 fp = PerlIO_open(pmc, mode);
2825 fp = PerlIO_open(name, mode);
2828 SvREFCNT_dec(pmcsv);
2831 fp = PerlIO_open(name, mode);
2839 register PERL_CONTEXT *cx;
2844 SV *namesv = Nullsv;
2846 I32 gimme = G_SCALAR;
2847 PerlIO *tryrsfp = 0;
2851 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2852 SET_NUMERIC_STANDARD();
2853 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2854 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2855 SvPV(sv,n_a),PL_patchlevel);
2858 name = SvPV(sv, len);
2859 if (!(name && len > 0 && *name))
2860 DIE(aTHX_ "Null filename used");
2861 TAINT_PROPER("require");
2862 if (PL_op->op_type == OP_REQUIRE &&
2863 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2864 *svp != &PL_sv_undef)
2867 /* prepare to compile file */
2872 (name[1] == '.' && name[2] == '/')))
2874 || (name[0] && name[1] == ':')
2877 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2880 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2881 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2886 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2889 AV *ar = GvAVn(PL_incgv);
2893 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2896 namesv = NEWSV(806, 0);
2897 for (i = 0; i <= AvFILL(ar); i++) {
2898 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2901 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2903 sv_setpv(namesv, unixdir);
2904 sv_catpv(namesv, unixname);
2906 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2908 TAINT_PROPER("require");
2909 tryname = SvPVX(namesv);
2910 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2912 if (tryname[0] == '.' && tryname[1] == '/')
2919 SAVESPTR(PL_compiling.cop_filegv);
2920 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2921 SvREFCNT_dec(namesv);
2923 if (PL_op->op_type == OP_REQUIRE) {
2924 char *msgstr = name;
2925 if (namesv) { /* did we lookup @INC? */
2926 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2927 SV *dirmsgsv = NEWSV(0, 0);
2928 AV *ar = GvAVn(PL_incgv);
2930 sv_catpvn(msg, " in @INC", 8);
2931 if (instr(SvPVX(msg), ".h "))
2932 sv_catpv(msg, " (change .h to .ph maybe?)");
2933 if (instr(SvPVX(msg), ".ph "))
2934 sv_catpv(msg, " (did you run h2ph?)");
2935 sv_catpv(msg, " (@INC contains:");
2936 for (i = 0; i <= AvFILL(ar); i++) {
2937 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2938 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
2939 sv_catsv(msg, dirmsgsv);
2941 sv_catpvn(msg, ")", 1);
2942 SvREFCNT_dec(dirmsgsv);
2943 msgstr = SvPV_nolen(msg);
2945 DIE(aTHX_ "Can't locate %s", msgstr);
2951 SETERRNO(0, SS$_NORMAL);
2953 /* Assume success here to prevent recursive requirement. */
2954 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2955 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2959 lex_start(sv_2mortal(newSVpvn("",0)));
2960 SAVEGENERICSV(PL_rsfp_filters);
2961 PL_rsfp_filters = Nullav;
2964 name = savepv(name);
2968 SAVEPPTR(PL_compiling.cop_warnings);
2969 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2972 /* switch to eval mode */
2974 push_return(PL_op->op_next);
2975 PUSHBLOCK(cx, CXt_EVAL, SP);
2976 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2978 SAVEI16(PL_compiling.cop_line);
2979 PL_compiling.cop_line = 0;
2983 MUTEX_LOCK(&PL_eval_mutex);
2984 if (PL_eval_owner && PL_eval_owner != thr)
2985 while (PL_eval_owner)
2986 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2987 PL_eval_owner = thr;
2988 MUTEX_UNLOCK(&PL_eval_mutex);
2989 #endif /* USE_THREADS */
2990 return DOCATCH(doeval(G_SCALAR, NULL));
2995 return pp_require();
3001 register PERL_CONTEXT *cx;
3003 I32 gimme = GIMME_V, was = PL_sub_generation;
3004 char tmpbuf[TYPE_DIGITS(long) + 12];
3009 if (!SvPV(sv,len) || !len)
3011 TAINT_PROPER("eval");
3017 /* switch to eval mode */
3019 SAVESPTR(PL_compiling.cop_filegv);
3020 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3021 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3022 PL_compiling.cop_line = 1;
3023 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3024 deleting the eval's FILEGV from the stash before gv_check() runs
3025 (i.e. before run-time proper). To work around the coredump that
3026 ensues, we always turn GvMULTI_on for any globals that were
3027 introduced within evals. See force_ident(). GSAR 96-10-12 */
3028 safestr = savepv(tmpbuf);
3029 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3031 PL_hints = PL_op->op_targ;
3032 SAVEPPTR(PL_compiling.cop_warnings);
3033 if (PL_compiling.cop_warnings != WARN_ALL
3034 && PL_compiling.cop_warnings != WARN_NONE){
3035 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3036 SAVEFREESV(PL_compiling.cop_warnings) ;
3039 push_return(PL_op->op_next);
3040 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3041 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3043 /* prepare to compile string */
3045 if (PERLDB_LINE && PL_curstash != PL_debstash)
3046 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3049 MUTEX_LOCK(&PL_eval_mutex);
3050 if (PL_eval_owner && PL_eval_owner != thr)
3051 while (PL_eval_owner)
3052 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3053 PL_eval_owner = thr;
3054 MUTEX_UNLOCK(&PL_eval_mutex);
3055 #endif /* USE_THREADS */
3056 ret = doeval(gimme, NULL);
3057 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3058 && ret != PL_op->op_next) { /* Successive compilation. */
3059 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3061 return DOCATCH(ret);
3071 register PERL_CONTEXT *cx;
3073 U8 save_flags = PL_op -> op_flags;
3078 retop = pop_return();
3081 if (gimme == G_VOID)
3083 else if (gimme == G_SCALAR) {
3086 if (SvFLAGS(TOPs) & SVs_TEMP)
3089 *MARK = sv_mortalcopy(TOPs);
3093 *MARK = &PL_sv_undef;
3097 /* in case LEAVE wipes old return values */
3098 for (mark = newsp + 1; mark <= SP; mark++) {
3099 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3100 *mark = sv_mortalcopy(*mark);
3101 TAINT_NOT; /* Each item is independent */
3105 PL_curpm = newpm; /* Don't pop $1 et al till now */
3107 if (AvFILLp(PL_comppad_name) >= 0)
3111 assert(CvDEPTH(PL_compcv) == 1);
3113 CvDEPTH(PL_compcv) = 0;
3116 if (optype == OP_REQUIRE &&
3117 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3119 /* Unassume the success we assumed earlier. */
3120 char *name = cx->blk_eval.old_name;
3121 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3122 retop = Perl_die(aTHX_ "%s did not return a true value", name);
3123 /* die_where() did LEAVE, or we won't be here */
3127 if (!(save_flags & OPf_SPECIAL))
3137 register PERL_CONTEXT *cx;
3138 I32 gimme = GIMME_V;
3143 push_return(cLOGOP->op_other->op_next);
3144 PUSHBLOCK(cx, CXt_EVAL, SP);
3146 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3148 PL_in_eval = EVAL_INEVAL;
3151 return DOCATCH(PL_op->op_next);
3161 register PERL_CONTEXT *cx;
3169 if (gimme == G_VOID)
3171 else if (gimme == G_SCALAR) {
3174 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3177 *MARK = sv_mortalcopy(TOPs);
3181 *MARK = &PL_sv_undef;
3186 /* in case LEAVE wipes old return values */
3187 for (mark = newsp + 1; mark <= SP; mark++) {
3188 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3189 *mark = sv_mortalcopy(*mark);
3190 TAINT_NOT; /* Each item is independent */
3194 PL_curpm = newpm; /* Don't pop $1 et al till now */
3202 S_doparseform(pTHX_ SV *sv)
3205 register char *s = SvPV_force(sv, len);
3206 register char *send = s + len;
3207 register char *base;
3208 register I32 skipspaces = 0;
3211 bool postspace = FALSE;
3219 Perl_croak(aTHX_ "Null picture in formline");
3221 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3226 *fpc++ = FF_LINEMARK;
3227 noblank = repeat = FALSE;
3245 case ' ': case '\t':
3256 *fpc++ = FF_LITERAL;
3264 *fpc++ = skipspaces;
3268 *fpc++ = FF_NEWLINE;
3272 arg = fpc - linepc + 1;
3279 *fpc++ = FF_LINEMARK;
3280 noblank = repeat = FALSE;
3289 ischop = s[-1] == '^';
3295 arg = (s - base) - 1;
3297 *fpc++ = FF_LITERAL;
3306 *fpc++ = FF_LINEGLOB;
3308 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3309 arg = ischop ? 512 : 0;
3319 arg |= 256 + (s - f);
3321 *fpc++ = s - base; /* fieldsize for FETCH */
3322 *fpc++ = FF_DECIMAL;
3327 bool ismore = FALSE;
3330 while (*++s == '>') ;
3331 prespace = FF_SPACE;
3333 else if (*s == '|') {
3334 while (*++s == '|') ;
3335 prespace = FF_HALFSPACE;
3340 while (*++s == '<') ;
3343 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3347 *fpc++ = s - base; /* fieldsize for FETCH */
3349 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3367 { /* need to jump to the next word */
3369 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3370 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3371 s = SvPVX(sv) + SvCUR(sv) + z;
3373 Copy(fops, s, arg, U16);
3375 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3380 * The rest of this file was derived from source code contributed
3383 * NOTE: this code was derived from Tom Horsley's qsort replacement
3384 * and should not be confused with the original code.
3387 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3389 Permission granted to distribute under the same terms as perl which are
3392 This program is free software; you can redistribute it and/or modify
3393 it under the terms of either:
3395 a) the GNU General Public License as published by the Free
3396 Software Foundation; either version 1, or (at your option) any
3399 b) the "Artistic License" which comes with this Kit.
3401 Details on the perl license can be found in the perl source code which
3402 may be located via the www.perl.com web page.
3404 This is the most wonderfulest possible qsort I can come up with (and
3405 still be mostly portable) My (limited) tests indicate it consistently
3406 does about 20% fewer calls to compare than does the qsort in the Visual
3407 C++ library, other vendors may vary.
3409 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3410 others I invented myself (or more likely re-invented since they seemed
3411 pretty obvious once I watched the algorithm operate for a while).
3413 Most of this code was written while watching the Marlins sweep the Giants
3414 in the 1997 National League Playoffs - no Braves fans allowed to use this
3415 code (just kidding :-).
3417 I realize that if I wanted to be true to the perl tradition, the only
3418 comment in this file would be something like:
3420 ...they shuffled back towards the rear of the line. 'No, not at the
3421 rear!' the slave-driver shouted. 'Three files up. And stay there...
3423 However, I really needed to violate that tradition just so I could keep
3424 track of what happens myself, not to mention some poor fool trying to
3425 understand this years from now :-).
3428 /* ********************************************************** Configuration */
3430 #ifndef QSORT_ORDER_GUESS
3431 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3434 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3435 future processing - a good max upper bound is log base 2 of memory size
3436 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3437 safely be smaller than that since the program is taking up some space and
3438 most operating systems only let you grab some subset of contiguous
3439 memory (not to mention that you are normally sorting data larger than
3440 1 byte element size :-).
3442 #ifndef QSORT_MAX_STACK
3443 #define QSORT_MAX_STACK 32
3446 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3447 Anything bigger and we use qsort. If you make this too small, the qsort
3448 will probably break (or become less efficient), because it doesn't expect
3449 the middle element of a partition to be the same as the right or left -
3450 you have been warned).
3452 #ifndef QSORT_BREAK_EVEN
3453 #define QSORT_BREAK_EVEN 6
3456 /* ************************************************************* Data Types */
3458 /* hold left and right index values of a partition waiting to be sorted (the
3459 partition includes both left and right - right is NOT one past the end or
3460 anything like that).
3462 struct partition_stack_entry {
3465 #ifdef QSORT_ORDER_GUESS
3466 int qsort_break_even;
3470 /* ******************************************************* Shorthand Macros */
3472 /* Note that these macros will be used from inside the qsort function where
3473 we happen to know that the variable 'elt_size' contains the size of an
3474 array element and the variable 'temp' points to enough space to hold a
3475 temp element and the variable 'array' points to the array being sorted
3476 and 'compare' is the pointer to the compare routine.
3478 Also note that there are very many highly architecture specific ways
3479 these might be sped up, but this is simply the most generally portable
3480 code I could think of.
3483 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3486 #define qsort_cmp(elt1, elt2) \
3487 ((this->*compare)(array[elt1], array[elt2]))
3489 #define qsort_cmp(elt1, elt2) \
3490 ((*compare)(aTHX_ array[elt1], array[elt2]))
3493 #ifdef QSORT_ORDER_GUESS
3494 #define QSORT_NOTICE_SWAP swapped++;
3496 #define QSORT_NOTICE_SWAP
3499 /* swaps contents of array elements elt1, elt2.
3501 #define qsort_swap(elt1, elt2) \
3504 temp = array[elt1]; \
3505 array[elt1] = array[elt2]; \
3506 array[elt2] = temp; \
3509 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3510 elt3 and elt3 gets elt1.
3512 #define qsort_rotate(elt1, elt2, elt3) \
3515 temp = array[elt1]; \
3516 array[elt1] = array[elt2]; \
3517 array[elt2] = array[elt3]; \
3518 array[elt3] = temp; \
3521 /* ************************************************************ Debug stuff */
3528 return; /* good place to set a breakpoint */
3531 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3534 doqsort_all_asserts(
3538 int (*compare)(const void * elt1, const void * elt2),
3539 int pc_left, int pc_right, int u_left, int u_right)
3543 qsort_assert(pc_left <= pc_right);
3544 qsort_assert(u_right < pc_left);
3545 qsort_assert(pc_right < u_left);
3546 for (i = u_right + 1; i < pc_left; ++i) {
3547 qsort_assert(qsort_cmp(i, pc_left) < 0);
3549 for (i = pc_left; i < pc_right; ++i) {
3550 qsort_assert(qsort_cmp(i, pc_right) == 0);
3552 for (i = pc_right + 1; i < u_left; ++i) {
3553 qsort_assert(qsort_cmp(pc_right, i) < 0);
3557 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3558 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3559 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3563 #define qsort_assert(t) ((void)0)
3565 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3569 /* ****************************************************************** qsort */
3572 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3576 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3577 int next_stack_entry = 0;
3581 #ifdef QSORT_ORDER_GUESS
3582 int qsort_break_even;
3586 /* Make sure we actually have work to do.
3588 if (num_elts <= 1) {
3592 /* Setup the initial partition definition and fall into the sorting loop
3595 part_right = (int)(num_elts - 1);
3596 #ifdef QSORT_ORDER_GUESS
3597 qsort_break_even = QSORT_BREAK_EVEN;
3599 #define qsort_break_even QSORT_BREAK_EVEN
3602 if ((part_right - part_left) >= qsort_break_even) {
3603 /* OK, this is gonna get hairy, so lets try to document all the
3604 concepts and abbreviations and variables and what they keep
3607 pc: pivot chunk - the set of array elements we accumulate in the
3608 middle of the partition, all equal in value to the original
3609 pivot element selected. The pc is defined by:
3611 pc_left - the leftmost array index of the pc
3612 pc_right - the rightmost array index of the pc
3614 we start with pc_left == pc_right and only one element
3615 in the pivot chunk (but it can grow during the scan).
3617 u: uncompared elements - the set of elements in the partition
3618 we have not yet compared to the pivot value. There are two
3619 uncompared sets during the scan - one to the left of the pc
3620 and one to the right.
3622 u_right - the rightmost index of the left side's uncompared set
3623 u_left - the leftmost index of the right side's uncompared set
3625 The leftmost index of the left sides's uncompared set
3626 doesn't need its own variable because it is always defined
3627 by the leftmost edge of the whole partition (part_left). The
3628 same goes for the rightmost edge of the right partition
3631 We know there are no uncompared elements on the left once we
3632 get u_right < part_left and no uncompared elements on the
3633 right once u_left > part_right. When both these conditions
3634 are met, we have completed the scan of the partition.
3636 Any elements which are between the pivot chunk and the
3637 uncompared elements should be less than the pivot value on
3638 the left side and greater than the pivot value on the right
3639 side (in fact, the goal of the whole algorithm is to arrange
3640 for that to be true and make the groups of less-than and
3641 greater-then elements into new partitions to sort again).
3643 As you marvel at the complexity of the code and wonder why it
3644 has to be so confusing. Consider some of the things this level
3645 of confusion brings:
3647 Once I do a compare, I squeeze every ounce of juice out of it. I
3648 never do compare calls I don't have to do, and I certainly never
3651 I also never swap any elements unless I can prove there is a
3652 good reason. Many sort algorithms will swap a known value with
3653 an uncompared value just to get things in the right place (or
3654 avoid complexity :-), but that uncompared value, once it gets
3655 compared, may then have to be swapped again. A lot of the
3656 complexity of this code is due to the fact that it never swaps
3657 anything except compared values, and it only swaps them when the
3658 compare shows they are out of position.
3660 int pc_left, pc_right;
3661 int u_right, u_left;
3665 pc_left = ((part_left + part_right) / 2);
3667 u_right = pc_left - 1;
3668 u_left = pc_right + 1;
3670 /* Qsort works best when the pivot value is also the median value
3671 in the partition (unfortunately you can't find the median value
3672 without first sorting :-), so to give the algorithm a helping
3673 hand, we pick 3 elements and sort them and use the median value
3674 of that tiny set as the pivot value.
3676 Some versions of qsort like to use the left middle and right as
3677 the 3 elements to sort so they can insure the ends of the
3678 partition will contain values which will stop the scan in the
3679 compare loop, but when you have to call an arbitrarily complex
3680 routine to do a compare, its really better to just keep track of
3681 array index values to know when you hit the edge of the
3682 partition and avoid the extra compare. An even better reason to
3683 avoid using a compare call is the fact that you can drop off the
3684 edge of the array if someone foolishly provides you with an
3685 unstable compare function that doesn't always provide consistent
3688 So, since it is simpler for us to compare the three adjacent
3689 elements in the middle of the partition, those are the ones we
3690 pick here (conveniently pointed at by u_right, pc_left, and
3691 u_left). The values of the left, center, and right elements
3692 are refered to as l c and r in the following comments.
3695 #ifdef QSORT_ORDER_GUESS
3698 s = qsort_cmp(u_right, pc_left);
3701 s = qsort_cmp(pc_left, u_left);
3702 /* if l < c, c < r - already in order - nothing to do */
3704 /* l < c, c == r - already in order, pc grows */
3706 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3708 /* l < c, c > r - need to know more */
3709 s = qsort_cmp(u_right, u_left);
3711 /* l < c, c > r, l < r - swap c & r to get ordered */
3712 qsort_swap(pc_left, u_left);
3713 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3714 } else if (s == 0) {
3715 /* l < c, c > r, l == r - swap c&r, grow pc */
3716 qsort_swap(pc_left, u_left);
3718 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3720 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3721 qsort_rotate(pc_left, u_right, u_left);
3722 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3725 } else if (s == 0) {
3727 s = qsort_cmp(pc_left, u_left);
3729 /* l == c, c < r - already in order, grow pc */
3731 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3732 } else if (s == 0) {
3733 /* l == c, c == r - already in order, grow pc both ways */
3736 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3738 /* l == c, c > r - swap l & r, grow pc */
3739 qsort_swap(u_right, u_left);
3741 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3745 s = qsort_cmp(pc_left, u_left);
3747 /* l > c, c < r - need to know more */
3748 s = qsort_cmp(u_right, u_left);
3750 /* l > c, c < r, l < r - swap l & c to get ordered */
3751 qsort_swap(u_right, pc_left);
3752 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3753 } else if (s == 0) {
3754 /* l > c, c < r, l == r - swap l & c, grow pc */
3755 qsort_swap(u_right, pc_left);
3757 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3759 /* l > c, c < r, l > r - rotate lcr into crl to order */
3760 qsort_rotate(u_right, pc_left, u_left);
3761 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3763 } else if (s == 0) {
3764 /* l > c, c == r - swap ends, grow pc */
3765 qsort_swap(u_right, u_left);
3767 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3769 /* l > c, c > r - swap ends to get in order */
3770 qsort_swap(u_right, u_left);
3771 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3774 /* We now know the 3 middle elements have been compared and
3775 arranged in the desired order, so we can shrink the uncompared
3780 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3782 /* The above massive nested if was the simple part :-). We now have
3783 the middle 3 elements ordered and we need to scan through the
3784 uncompared sets on either side, swapping elements that are on
3785 the wrong side or simply shuffling equal elements around to get
3786 all equal elements into the pivot chunk.
3790 int still_work_on_left;
3791 int still_work_on_right;
3793 /* Scan the uncompared values on the left. If I find a value
3794 equal to the pivot value, move it over so it is adjacent to
3795 the pivot chunk and expand the pivot chunk. If I find a value
3796 less than the pivot value, then just leave it - its already
3797 on the correct side of the partition. If I find a greater
3798 value, then stop the scan.
3800 while (still_work_on_left = (u_right >= part_left)) {
3801 s = qsort_cmp(u_right, pc_left);
3804 } else if (s == 0) {
3806 if (pc_left != u_right) {
3807 qsort_swap(u_right, pc_left);
3813 qsort_assert(u_right < pc_left);
3814 qsort_assert(pc_left <= pc_right);
3815 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3816 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3819 /* Do a mirror image scan of uncompared values on the right
3821 while (still_work_on_right = (u_left <= part_right)) {
3822 s = qsort_cmp(pc_right, u_left);
3825 } else if (s == 0) {
3827 if (pc_right != u_left) {
3828 qsort_swap(pc_right, u_left);
3834 qsort_assert(u_left > pc_right);
3835 qsort_assert(pc_left <= pc_right);
3836 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3837 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3840 if (still_work_on_left) {
3841 /* I know I have a value on the left side which needs to be
3842 on the right side, but I need to know more to decide
3843 exactly the best thing to do with it.
3845 if (still_work_on_right) {
3846 /* I know I have values on both side which are out of
3847 position. This is a big win because I kill two birds
3848 with one swap (so to speak). I can advance the
3849 uncompared pointers on both sides after swapping both
3850 of them into the right place.
3852 qsort_swap(u_right, u_left);
3855 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3857 /* I have an out of position value on the left, but the
3858 right is fully scanned, so I "slide" the pivot chunk
3859 and any less-than values left one to make room for the
3860 greater value over on the right. If the out of position
3861 value is immediately adjacent to the pivot chunk (there
3862 are no less-than values), I can do that with a swap,
3863 otherwise, I have to rotate one of the less than values
3864 into the former position of the out of position value
3865 and the right end of the pivot chunk into the left end
3869 if (pc_left == u_right) {
3870 qsort_swap(u_right, pc_right);
3871 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3873 qsort_rotate(u_right, pc_left, pc_right);
3874 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3879 } else if (still_work_on_right) {
3880 /* Mirror image of complex case above: I have an out of
3881 position value on the right, but the left is fully
3882 scanned, so I need to shuffle things around to make room
3883 for the right value on the left.
3886 if (pc_right == u_left) {
3887 qsort_swap(u_left, pc_left);
3888 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3890 qsort_rotate(pc_right, pc_left, u_left);
3891 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3896 /* No more scanning required on either side of partition,
3897 break out of loop and figure out next set of partitions
3903 /* The elements in the pivot chunk are now in the right place. They
3904 will never move or be compared again. All I have to do is decide
3905 what to do with the stuff to the left and right of the pivot
3908 Notes on the QSORT_ORDER_GUESS ifdef code:
3910 1. If I just built these partitions without swapping any (or
3911 very many) elements, there is a chance that the elements are
3912 already ordered properly (being properly ordered will
3913 certainly result in no swapping, but the converse can't be
3916 2. A (properly written) insertion sort will run faster on
3917 already ordered data than qsort will.
3919 3. Perhaps there is some way to make a good guess about
3920 switching to an insertion sort earlier than partition size 6
3921 (for instance - we could save the partition size on the stack
3922 and increase the size each time we find we didn't swap, thus
3923 switching to insertion sort earlier for partitions with a
3924 history of not swapping).
3926 4. Naturally, if I just switch right away, it will make
3927 artificial benchmarks with pure ascending (or descending)
3928 data look really good, but is that a good reason in general?
3932 #ifdef QSORT_ORDER_GUESS
3934 #if QSORT_ORDER_GUESS == 1
3935 qsort_break_even = (part_right - part_left) + 1;
3937 #if QSORT_ORDER_GUESS == 2
3938 qsort_break_even *= 2;
3940 #if QSORT_ORDER_GUESS == 3
3941 int prev_break = qsort_break_even;
3942 qsort_break_even *= qsort_break_even;
3943 if (qsort_break_even < prev_break) {
3944 qsort_break_even = (part_right - part_left) + 1;
3948 qsort_break_even = QSORT_BREAK_EVEN;
3952 if (part_left < pc_left) {
3953 /* There are elements on the left which need more processing.
3954 Check the right as well before deciding what to do.
3956 if (pc_right < part_right) {
3957 /* We have two partitions to be sorted. Stack the biggest one
3958 and process the smallest one on the next iteration. This
3959 minimizes the stack height by insuring that any additional
3960 stack entries must come from the smallest partition which
3961 (because it is smallest) will have the fewest
3962 opportunities to generate additional stack entries.
3964 if ((part_right - pc_right) > (pc_left - part_left)) {
3965 /* stack the right partition, process the left */
3966 partition_stack[next_stack_entry].left = pc_right + 1;
3967 partition_stack[next_stack_entry].right = part_right;
3968 #ifdef QSORT_ORDER_GUESS
3969 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3971 part_right = pc_left - 1;
3973 /* stack the left partition, process the right */
3974 partition_stack[next_stack_entry].left = part_left;
3975 partition_stack[next_stack_entry].right = pc_left - 1;
3976 #ifdef QSORT_ORDER_GUESS
3977 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3979 part_left = pc_right + 1;
3981 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3984 /* The elements on the left are the only remaining elements
3985 that need sorting, arrange for them to be processed as the
3988 part_right = pc_left - 1;
3990 } else if (pc_right < part_right) {
3991 /* There is only one chunk on the right to be sorted, make it
3992 the new partition and loop back around.
3994 part_left = pc_right + 1;
3996 /* This whole partition wound up in the pivot chunk, so
3997 we need to get a new partition off the stack.
3999 if (next_stack_entry == 0) {
4000 /* the stack is empty - we are done */
4004 part_left = partition_stack[next_stack_entry].left;
4005 part_right = partition_stack[next_stack_entry].right;
4006 #ifdef QSORT_ORDER_GUESS
4007 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4011 /* This partition is too small to fool with qsort complexity, just
4012 do an ordinary insertion sort to minimize overhead.
4015 /* Assume 1st element is in right place already, and start checking
4016 at 2nd element to see where it should be inserted.
4018 for (i = part_left + 1; i <= part_right; ++i) {
4020 /* Scan (backwards - just in case 'i' is already in right place)
4021 through the elements already sorted to see if the ith element
4022 belongs ahead of one of them.
4024 for (j = i - 1; j >= part_left; --j) {
4025 if (qsort_cmp(i, j) >= 0) {
4026 /* i belongs right after j
4033 /* Looks like we really need to move some things
4037 for (k = i - 1; k >= j; --k)
4038 array[k + 1] = array[k];
4043 /* That partition is now sorted, grab the next one, or get out
4044 of the loop if there aren't any more.
4047 if (next_stack_entry == 0) {
4048 /* the stack is empty - we are done */
4052 part_left = partition_stack[next_stack_entry].left;
4053 part_right = partition_stack[next_stack_entry].right;
4054 #ifdef QSORT_ORDER_GUESS
4055 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4060 /* Believe it or not, the array is sorted at this point! */