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". */
571 RESTORE_NUMERIC_LOCAL();
574 (int) fieldsize, (int) arg & 255, value);
577 (int) fieldsize, value);
579 RESTORE_NUMERIC_STANDARD();
586 while (t-- > linemark && *t == ' ') ;
594 if (arg) { /* repeat until fields exhausted? */
596 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
597 lines += FmLINES(PL_formtarget);
600 if (strnEQ(linemark, linemark - arg, arg))
601 DIE(aTHX_ "Runaway format");
603 FmLINES(PL_formtarget) = lines;
605 RETURNOP(cLISTOP->op_first);
618 while (*s && isSPACE(*s) && s < send)
622 arg = fieldsize - itemsize;
629 if (strnEQ(s," ",3)) {
630 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
641 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
642 FmLINES(PL_formtarget) += lines;
654 if (PL_stack_base + *PL_markstack_ptr == SP) {
656 if (GIMME_V == G_SCALAR)
657 XPUSHs(sv_2mortal(newSViv(0)));
658 RETURNOP(PL_op->op_next->op_next);
660 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
661 pp_pushmark(); /* push dst */
662 pp_pushmark(); /* push src */
663 ENTER; /* enter outer scope */
666 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
668 ENTER; /* enter inner scope */
671 src = PL_stack_base[*PL_markstack_ptr];
676 if (PL_op->op_type == OP_MAPSTART)
677 pp_pushmark(); /* push top */
678 return ((LOGOP*)PL_op->op_next)->op_other;
683 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
689 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
695 ++PL_markstack_ptr[-1];
697 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
698 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
699 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
704 PL_markstack_ptr[-1] += shift;
705 *PL_markstack_ptr += shift;
709 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
712 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
714 LEAVE; /* exit inner scope */
717 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
721 (void)POPMARK; /* pop top */
722 LEAVE; /* exit outer scope */
723 (void)POPMARK; /* pop src */
724 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
725 (void)POPMARK; /* pop dst */
726 SP = PL_stack_base + POPMARK; /* pop original mark */
727 if (gimme == G_SCALAR) {
731 else if (gimme == G_ARRAY)
738 ENTER; /* enter inner scope */
741 src = PL_stack_base[PL_markstack_ptr[-1]];
745 RETURNOP(cLOGOP->op_other);
750 S_sv_ncmp(pTHX_ SV *a, SV *b)
752 double nv1 = SvNV(a);
753 double nv2 = SvNV(b);
754 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
758 S_sv_i_ncmp(pTHX_ SV *a, SV *b)
762 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
764 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
766 if (PL_amagic_generation) { \
767 if (SvAMAGIC(left)||SvAMAGIC(right))\
768 *svp = amagic_call(left, \
776 S_amagic_ncmp(pTHX_ register SV *a, register SV *b)
779 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
784 I32 i = SvIVX(tmpsv);
794 return sv_ncmp(a, b);
798 S_amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
801 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
806 I32 i = SvIVX(tmpsv);
816 return sv_i_ncmp(a, b);
820 S_amagic_cmp(pTHX_ register SV *str1, register SV *str2)
823 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
828 I32 i = SvIVX(tmpsv);
838 return sv_cmp(str1, str2);
842 S_amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
845 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
850 I32 i = SvIVX(tmpsv);
860 return sv_cmp_locale(str1, str2);
865 djSP; dMARK; dORIGMARK;
867 SV **myorigmark = ORIGMARK;
873 OP* nextop = PL_op->op_next;
876 if (gimme != G_ARRAY) {
882 SAVEPPTR(PL_sortcop);
883 if (PL_op->op_flags & OPf_STACKED) {
884 if (PL_op->op_flags & OPf_SPECIAL) {
885 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
886 kid = kUNOP->op_first; /* pass rv2gv */
887 kid = kUNOP->op_first; /* pass leave */
888 PL_sortcop = kid->op_next;
889 stash = PL_curcop->cop_stash;
892 cv = sv_2cv(*++MARK, &stash, &gv, 0);
893 if (!(cv && CvROOT(cv))) {
895 SV *tmpstr = sv_newmortal();
896 gv_efullname3(tmpstr, gv, Nullch);
897 if (cv && CvXSUB(cv))
898 DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
899 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
904 DIE(aTHX_ "Xsub called in sort");
905 DIE(aTHX_ "Undefined subroutine in sort");
907 DIE(aTHX_ "Not a CODE reference in sort");
909 PL_sortcop = CvSTART(cv);
910 SAVESPTR(CvROOT(cv)->op_ppaddr);
911 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
914 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
919 stash = PL_curcop->cop_stash;
923 while (MARK < SP) { /* This may or may not shift down one here. */
925 if (*up = *++MARK) { /* Weed out nulls. */
927 if (!PL_sortcop && !SvPOK(*up)) {
932 (void)sv_2pv(*up, &n_a);
937 max = --up - myorigmark;
942 bool oldcatch = CATCH_GET;
948 PUSHSTACKi(PERLSI_SORT);
949 if (PL_sortstash != stash) {
950 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
951 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
952 PL_sortstash = stash;
955 SAVESPTR(GvSV(PL_firstgv));
956 SAVESPTR(GvSV(PL_secondgv));
958 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
959 if (!(PL_op->op_flags & OPf_SPECIAL)) {
960 bool hasargs = FALSE;
961 cx->cx_type = CXt_SUB;
962 cx->blk_gimme = G_SCALAR;
965 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
967 PL_sortcxix = cxstack_ix;
968 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(S_sortcv));
970 POPBLOCK(cx,PL_curpm);
978 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
979 qsortsv(ORIGMARK+1, max,
980 (PL_op->op_private & OPpSORT_NUMERIC)
981 ? ( (PL_op->op_private & OPpSORT_INTEGER)
983 ? FUNC_NAME_TO_PTR(S_amagic_i_ncmp)
984 : FUNC_NAME_TO_PTR(S_sv_i_ncmp))
986 ? FUNC_NAME_TO_PTR(S_amagic_ncmp)
987 : FUNC_NAME_TO_PTR(S_sv_ncmp)))
988 : ( (PL_op->op_private & OPpLOCALE)
990 ? FUNC_NAME_TO_PTR(S_amagic_cmp_locale)
991 : FUNC_NAME_TO_PTR(Perl_sv_cmp_locale))
993 ? FUNC_NAME_TO_PTR(S_amagic_cmp)
994 : FUNC_NAME_TO_PTR(Perl_sv_cmp) )));
995 if (PL_op->op_private & OPpSORT_REVERSE) {
997 SV **q = ORIGMARK+max;
1007 PL_stack_sp = ORIGMARK + max;
1015 if (GIMME == G_ARRAY)
1016 return cCONDOP->op_true;
1017 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1018 return cCONDOP->op_false;
1020 return cCONDOP->op_true;
1027 if (GIMME == G_ARRAY) {
1028 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1032 SV *targ = PAD_SV(PL_op->op_targ);
1034 if ((PL_op->op_private & OPpFLIP_LINENUM)
1035 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1037 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1038 if (PL_op->op_flags & OPf_SPECIAL) {
1046 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1059 if (GIMME == G_ARRAY) {
1065 if (SvGMAGICAL(left))
1067 if (SvGMAGICAL(right))
1070 if (SvNIOKp(left) || !SvPOKp(left) ||
1071 (looks_like_number(left) && *SvPVX(left) != '0') )
1073 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1074 Perl_croak(aTHX_ "Range iterator outside integer range");
1085 sv = sv_2mortal(newSViv(i++));
1090 SV *final = sv_mortalcopy(right);
1092 char *tmps = SvPV(final, len);
1094 sv = sv_mortalcopy(left);
1096 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1098 if (strEQ(SvPVX(sv),tmps))
1100 sv = sv_2mortal(newSVsv(sv));
1107 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1109 if ((PL_op->op_private & OPpFLIP_LINENUM)
1110 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1112 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1113 sv_catpv(targ, "E0");
1124 S_dopoptolabel(pTHX_ char *label)
1128 register PERL_CONTEXT *cx;
1130 for (i = cxstack_ix; i >= 0; i--) {
1132 switch (CxTYPE(cx)) {
1134 if (ckWARN(WARN_UNSAFE))
1135 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1136 PL_op_name[PL_op->op_type]);
1139 if (ckWARN(WARN_UNSAFE))
1140 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1141 PL_op_name[PL_op->op_type]);
1144 if (ckWARN(WARN_UNSAFE))
1145 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1146 PL_op_name[PL_op->op_type]);
1149 if (ckWARN(WARN_UNSAFE))
1150 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1151 PL_op_name[PL_op->op_type]);
1154 if (!cx->blk_loop.label ||
1155 strNE(label, cx->blk_loop.label) ) {
1156 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1157 (long)i, cx->blk_loop.label));
1160 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1168 Perl_dowantarray(pTHX)
1170 I32 gimme = block_gimme();
1171 return (gimme == G_VOID) ? G_SCALAR : gimme;
1175 Perl_block_gimme(pTHX)
1180 cxix = dopoptosub(cxstack_ix);
1184 switch (cxstack[cxix].blk_gimme) {
1192 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1199 S_dopoptosub(pTHX_ I32 startingblock)
1202 return dopoptosub_at(cxstack, startingblock);
1206 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1210 register PERL_CONTEXT *cx;
1211 for (i = startingblock; i >= 0; i--) {
1213 switch (CxTYPE(cx)) {
1218 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1226 S_dopoptoeval(pTHX_ I32 startingblock)
1230 register PERL_CONTEXT *cx;
1231 for (i = startingblock; i >= 0; i--) {
1233 switch (CxTYPE(cx)) {
1237 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1245 S_dopoptoloop(pTHX_ I32 startingblock)
1249 register PERL_CONTEXT *cx;
1250 for (i = startingblock; i >= 0; i--) {
1252 switch (CxTYPE(cx)) {
1254 if (ckWARN(WARN_UNSAFE))
1255 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1256 PL_op_name[PL_op->op_type]);
1259 if (ckWARN(WARN_UNSAFE))
1260 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1261 PL_op_name[PL_op->op_type]);
1264 if (ckWARN(WARN_UNSAFE))
1265 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1266 PL_op_name[PL_op->op_type]);
1269 if (ckWARN(WARN_UNSAFE))
1270 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1271 PL_op_name[PL_op->op_type]);
1274 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1282 Perl_dounwind(pTHX_ I32 cxix)
1285 register PERL_CONTEXT *cx;
1289 while (cxstack_ix > cxix) {
1290 cx = &cxstack[cxstack_ix];
1291 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1292 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1293 /* Note: we don't need to restore the base context info till the end. */
1294 switch (CxTYPE(cx)) {
1297 continue; /* not break */
1315 * Closures mentioned at top level of eval cannot be referenced
1316 * again, and their presence indirectly causes a memory leak.
1317 * (Note that the fact that compcv and friends are still set here
1318 * is, AFAIK, an accident.) --Chip
1320 * XXX need to get comppad et al from eval's cv rather than
1321 * relying on the incidental global values.
1324 S_free_closures(pTHX)
1327 SV **svp = AvARRAY(PL_comppad_name);
1329 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1331 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1333 svp[ix] = &PL_sv_undef;
1337 SvREFCNT_dec(CvOUTSIDE(sv));
1338 CvOUTSIDE(sv) = Nullcv;
1351 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1357 register PERL_CONTEXT *cx;
1362 if (PL_in_eval & EVAL_KEEPERR) {
1365 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1368 static char prefix[] = "\t(in cleanup) ";
1370 sv_upgrade(*svp, SVt_IV);
1371 (void)SvIOK_only(*svp);
1374 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1375 sv_catpvn(err, prefix, sizeof(prefix)-1);
1376 sv_catpvn(err, message, msglen);
1377 if (ckWARN(WARN_UNSAFE)) {
1378 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1379 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1386 sv_setpvn(ERRSV, message, msglen);
1389 message = SvPVx(ERRSV, msglen);
1391 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1399 if (cxix < cxstack_ix)
1402 POPBLOCK(cx,PL_curpm);
1403 if (CxTYPE(cx) != CXt_EVAL) {
1404 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1405 PerlIO_write(PerlIO_stderr(), message, msglen);
1410 if (gimme == G_SCALAR)
1411 *++newsp = &PL_sv_undef;
1412 PL_stack_sp = newsp;
1416 if (optype == OP_REQUIRE) {
1417 char* msg = SvPVx(ERRSV, n_a);
1418 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
1420 return pop_return();
1424 message = SvPVx(ERRSV, msglen);
1427 /* SFIO can really mess with your errno */
1430 PerlIO_write(PerlIO_stderr(), message, msglen);
1431 (void)PerlIO_flush(PerlIO_stderr());
1444 if (SvTRUE(left) != SvTRUE(right))
1456 RETURNOP(cLOGOP->op_other);
1465 RETURNOP(cLOGOP->op_other);
1471 register I32 cxix = dopoptosub(cxstack_ix);
1472 register PERL_CONTEXT *cx;
1473 register PERL_CONTEXT *ccstack = cxstack;
1474 PERL_SI *top_si = PL_curstackinfo;
1485 /* we may be in a higher stacklevel, so dig down deeper */
1486 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1487 top_si = top_si->si_prev;
1488 ccstack = top_si->si_cxstack;
1489 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1492 if (GIMME != G_ARRAY)
1496 if (PL_DBsub && cxix >= 0 &&
1497 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1501 cxix = dopoptosub_at(ccstack, cxix - 1);
1504 cx = &ccstack[cxix];
1505 if (CxTYPE(cx) == CXt_SUB) {
1506 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1507 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1508 field below is defined for any cx. */
1509 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1510 cx = &ccstack[dbcxix];
1513 if (GIMME != G_ARRAY) {
1514 hv = cx->blk_oldcop->cop_stash;
1516 PUSHs(&PL_sv_undef);
1519 sv_setpv(TARG, HvNAME(hv));
1525 hv = cx->blk_oldcop->cop_stash;
1527 PUSHs(&PL_sv_undef);
1529 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1530 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1531 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1532 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1535 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1537 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1538 PUSHs(sv_2mortal(sv));
1539 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1542 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1543 PUSHs(sv_2mortal(newSViv(0)));
1545 gimme = (I32)cx->blk_gimme;
1546 if (gimme == G_VOID)
1547 PUSHs(&PL_sv_undef);
1549 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1550 if (CxTYPE(cx) == CXt_EVAL) {
1551 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1552 PUSHs(cx->blk_eval.cur_text);
1555 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1556 /* Require, put the name. */
1557 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1561 else if (CxTYPE(cx) == CXt_SUB &&
1562 cx->blk_sub.hasargs &&
1563 PL_curcop->cop_stash == PL_debstash)
1565 AV *ary = cx->blk_sub.argarray;
1566 int off = AvARRAY(ary) - AvALLOC(ary);
1570 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1573 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1576 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1577 av_extend(PL_dbargs, AvFILLp(ary) + off);
1578 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1579 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1581 /* XXX only hints propagated via op_private are currently
1582 * visible (others are not easily accessible, since they
1583 * use the global PL_hints) */
1584 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1585 HINT_PRIVATE_MASK)));
1590 S_sortcv(pTHX_ SV *a, SV *b)
1593 I32 oldsaveix = PL_savestack_ix;
1594 I32 oldscopeix = PL_scopestack_ix;
1596 GvSV(PL_firstgv) = a;
1597 GvSV(PL_secondgv) = b;
1598 PL_stack_sp = PL_stack_base;
1601 if (PL_stack_sp != PL_stack_base + 1)
1602 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
1603 if (!SvNIOKp(*PL_stack_sp))
1604 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
1605 result = SvIV(*PL_stack_sp);
1606 while (PL_scopestack_ix > oldscopeix) {
1609 leave_scope(oldsaveix);
1623 sv_reset(tmps, PL_curcop->cop_stash);
1635 PL_curcop = (COP*)PL_op;
1636 TAINT_NOT; /* Each statement is presumed innocent */
1637 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1640 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1644 register PERL_CONTEXT *cx;
1645 I32 gimme = G_ARRAY;
1652 DIE(aTHX_ "No DB::DB routine defined");
1654 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1666 push_return(PL_op->op_next);
1667 PUSHBLOCK(cx, CXt_SUB, SP);
1670 (void)SvREFCNT_inc(cv);
1671 SAVESPTR(PL_curpad);
1672 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1673 RETURNOP(CvSTART(cv));
1687 register PERL_CONTEXT *cx;
1688 I32 gimme = GIMME_V;
1695 if (PL_op->op_flags & OPf_SPECIAL) {
1697 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1698 SAVEGENERICSV(*svp);
1702 #endif /* USE_THREADS */
1703 if (PL_op->op_targ) {
1704 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1708 svp = &GvSV((GV*)POPs); /* symbol table variable */
1709 SAVEGENERICSV(*svp);
1715 PUSHBLOCK(cx, CXt_LOOP, SP);
1716 PUSHLOOP(cx, svp, MARK);
1717 if (PL_op->op_flags & OPf_STACKED) {
1718 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1719 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1721 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1722 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1723 if (SvNV(sv) < IV_MIN ||
1724 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1725 Perl_croak(aTHX_ "Range iterator outside integer range");
1726 cx->blk_loop.iterix = SvIV(sv);
1727 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1730 cx->blk_loop.iterlval = newSVsv(sv);
1734 cx->blk_loop.iterary = PL_curstack;
1735 AvFILLp(PL_curstack) = SP - PL_stack_base;
1736 cx->blk_loop.iterix = MARK - PL_stack_base;
1745 register PERL_CONTEXT *cx;
1746 I32 gimme = GIMME_V;
1752 PUSHBLOCK(cx, CXt_LOOP, SP);
1753 PUSHLOOP(cx, 0, SP);
1761 register PERL_CONTEXT *cx;
1762 struct block_loop cxloop;
1770 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1773 if (gimme == G_VOID)
1775 else if (gimme == G_SCALAR) {
1777 *++newsp = sv_mortalcopy(*SP);
1779 *++newsp = &PL_sv_undef;
1783 *++newsp = sv_mortalcopy(*++mark);
1784 TAINT_NOT; /* Each item is independent */
1790 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1791 PL_curpm = newpm; /* ... and pop $1 et al */
1803 register PERL_CONTEXT *cx;
1804 struct block_sub cxsub;
1805 bool popsub2 = FALSE;
1811 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1812 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1813 if (cxstack_ix > PL_sortcxix)
1814 dounwind(PL_sortcxix);
1815 AvARRAY(PL_curstack)[1] = *SP;
1816 PL_stack_sp = PL_stack_base + 1;
1821 cxix = dopoptosub(cxstack_ix);
1823 DIE(aTHX_ "Can't return outside a subroutine");
1824 if (cxix < cxstack_ix)
1828 switch (CxTYPE(cx)) {
1830 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1835 if (AvFILLp(PL_comppad_name) >= 0)
1838 if (optype == OP_REQUIRE &&
1839 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1841 /* Unassume the success we assumed earlier. */
1842 char *name = cx->blk_eval.old_name;
1843 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1844 DIE(aTHX_ "%s did not return a true value", name);
1848 DIE(aTHX_ "panic: return");
1852 if (gimme == G_SCALAR) {
1855 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1857 *++newsp = SvREFCNT_inc(*SP);
1862 *++newsp = sv_mortalcopy(*SP);
1865 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1867 *++newsp = sv_mortalcopy(*SP);
1869 *++newsp = &PL_sv_undef;
1871 else if (gimme == G_ARRAY) {
1872 while (++MARK <= SP) {
1873 *++newsp = (popsub2 && SvTEMP(*MARK))
1874 ? *MARK : sv_mortalcopy(*MARK);
1875 TAINT_NOT; /* Each item is independent */
1878 PL_stack_sp = newsp;
1880 /* Stack values are safe: */
1882 POPSUB2(); /* release CV and @_ ... */
1884 PL_curpm = newpm; /* ... and pop $1 et al */
1887 return pop_return();
1894 register PERL_CONTEXT *cx;
1895 struct block_loop cxloop;
1896 struct block_sub cxsub;
1903 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1905 if (PL_op->op_flags & OPf_SPECIAL) {
1906 cxix = dopoptoloop(cxstack_ix);
1908 DIE(aTHX_ "Can't \"last\" outside a block");
1911 cxix = dopoptolabel(cPVOP->op_pv);
1913 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1915 if (cxix < cxstack_ix)
1919 switch (CxTYPE(cx)) {
1921 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1923 nextop = cxloop.last_op->op_next;
1926 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1928 nextop = pop_return();
1932 nextop = pop_return();
1935 DIE(aTHX_ "panic: last");
1939 if (gimme == G_SCALAR) {
1941 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1942 ? *SP : sv_mortalcopy(*SP);
1944 *++newsp = &PL_sv_undef;
1946 else if (gimme == G_ARRAY) {
1947 while (++MARK <= SP) {
1948 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1949 ? *MARK : sv_mortalcopy(*MARK);
1950 TAINT_NOT; /* Each item is independent */
1956 /* Stack values are safe: */
1959 POPLOOP2(); /* release loop vars ... */
1963 POPSUB2(); /* release CV and @_ ... */
1966 PL_curpm = newpm; /* ... and pop $1 et al */
1975 register PERL_CONTEXT *cx;
1978 if (PL_op->op_flags & OPf_SPECIAL) {
1979 cxix = dopoptoloop(cxstack_ix);
1981 DIE(aTHX_ "Can't \"next\" outside a block");
1984 cxix = dopoptolabel(cPVOP->op_pv);
1986 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1988 if (cxix < cxstack_ix)
1992 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1993 LEAVE_SCOPE(oldsave);
1994 return cx->blk_loop.next_op;
2000 register PERL_CONTEXT *cx;
2003 if (PL_op->op_flags & OPf_SPECIAL) {
2004 cxix = dopoptoloop(cxstack_ix);
2006 DIE(aTHX_ "Can't \"redo\" outside a block");
2009 cxix = dopoptolabel(cPVOP->op_pv);
2011 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2013 if (cxix < cxstack_ix)
2017 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2018 LEAVE_SCOPE(oldsave);
2019 return cx->blk_loop.redo_op;
2023 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2027 static char too_deep[] = "Target of goto is too deeply nested";
2030 Perl_croak(aTHX_ too_deep);
2031 if (o->op_type == OP_LEAVE ||
2032 o->op_type == OP_SCOPE ||
2033 o->op_type == OP_LEAVELOOP ||
2034 o->op_type == OP_LEAVETRY)
2036 *ops++ = cUNOPo->op_first;
2038 Perl_croak(aTHX_ too_deep);
2041 if (o->op_flags & OPf_KIDS) {
2043 /* First try all the kids at this level, since that's likeliest. */
2044 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2045 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2046 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2049 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2050 if (kid == PL_lastgotoprobe)
2052 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2054 (ops[-1]->op_type != OP_NEXTSTATE &&
2055 ops[-1]->op_type != OP_DBSTATE)))
2057 if (o = dofindlabel(kid, label, ops, oplimit))
2076 register PERL_CONTEXT *cx;
2077 #define GOTO_DEPTH 64
2078 OP *enterops[GOTO_DEPTH];
2080 int do_dump = (PL_op->op_type == OP_DUMP);
2081 static char must_have_label[] = "goto must have label";
2084 if (PL_op->op_flags & OPf_STACKED) {
2088 /* This egregious kludge implements goto &subroutine */
2089 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2091 register PERL_CONTEXT *cx;
2092 CV* cv = (CV*)SvRV(sv);
2096 int arg_was_real = 0;
2099 if (!CvROOT(cv) && !CvXSUB(cv)) {
2104 /* autoloaded stub? */
2105 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2107 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2108 GvNAMELEN(gv), FALSE);
2109 if (autogv && (cv = GvCV(autogv)))
2111 tmpstr = sv_newmortal();
2112 gv_efullname3(tmpstr, gv, Nullch);
2113 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2115 DIE(aTHX_ "Goto undefined subroutine");
2118 /* First do some returnish stuff. */
2119 cxix = dopoptosub(cxstack_ix);
2121 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2122 if (cxix < cxstack_ix)
2125 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2126 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2128 if (CxTYPE(cx) == CXt_SUB &&
2129 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2130 AV* av = cx->blk_sub.argarray;
2132 items = AvFILLp(av) + 1;
2134 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2135 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2136 PL_stack_sp += items;
2138 SvREFCNT_dec(GvAV(PL_defgv));
2139 GvAV(PL_defgv) = cx->blk_sub.savearray;
2140 #endif /* USE_THREADS */
2143 AvREAL_off(av); /* so av_clear() won't clobber elts */
2147 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2151 av = (AV*)PL_curpad[0];
2153 av = GvAV(PL_defgv);
2155 items = AvFILLp(av) + 1;
2157 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2158 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2159 PL_stack_sp += items;
2161 if (CxTYPE(cx) == CXt_SUB &&
2162 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2163 SvREFCNT_dec(cx->blk_sub.cv);
2164 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2165 LEAVE_SCOPE(oldsave);
2167 /* Now do some callish stuff. */
2170 #ifdef PERL_XSUB_OLDSTYLE
2171 if (CvOLDSTYLE(cv)) {
2172 I32 (*fp3)(int,int,int);
2177 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2178 items = (*fp3)(CvXSUBANY(cv).any_i32,
2179 mark - PL_stack_base + 1,
2181 SP = PL_stack_base + items;
2184 #endif /* PERL_XSUB_OLDSTYLE */
2189 PL_stack_sp--; /* There is no cv arg. */
2190 /* Push a mark for the start of arglist */
2192 (void)(*CvXSUB(cv))(aTHXo_ cv);
2193 /* Pop the current context like a decent sub should */
2194 POPBLOCK(cx, PL_curpm);
2195 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2198 return pop_return();
2201 AV* padlist = CvPADLIST(cv);
2202 SV** svp = AvARRAY(padlist);
2203 if (CxTYPE(cx) == CXt_EVAL) {
2204 PL_in_eval = cx->blk_eval.old_in_eval;
2205 PL_eval_root = cx->blk_eval.old_eval_root;
2206 cx->cx_type = CXt_SUB;
2207 cx->blk_sub.hasargs = 0;
2209 cx->blk_sub.cv = cv;
2210 cx->blk_sub.olddepth = CvDEPTH(cv);
2212 if (CvDEPTH(cv) < 2)
2213 (void)SvREFCNT_inc(cv);
2214 else { /* save temporaries on recursion? */
2215 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2216 sub_crush_depth(cv);
2217 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2218 AV *newpad = newAV();
2219 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2220 I32 ix = AvFILLp((AV*)svp[1]);
2221 svp = AvARRAY(svp[0]);
2222 for ( ;ix > 0; ix--) {
2223 if (svp[ix] != &PL_sv_undef) {
2224 char *name = SvPVX(svp[ix]);
2225 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2228 /* outer lexical or anon code */
2229 av_store(newpad, ix,
2230 SvREFCNT_inc(oldpad[ix]) );
2232 else { /* our own lexical */
2234 av_store(newpad, ix, sv = (SV*)newAV());
2235 else if (*name == '%')
2236 av_store(newpad, ix, sv = (SV*)newHV());
2238 av_store(newpad, ix, sv = NEWSV(0,0));
2243 av_store(newpad, ix, sv = NEWSV(0,0));
2247 if (cx->blk_sub.hasargs) {
2250 av_store(newpad, 0, (SV*)av);
2251 AvFLAGS(av) = AVf_REIFY;
2253 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2254 AvFILLp(padlist) = CvDEPTH(cv);
2255 svp = AvARRAY(padlist);
2259 if (!cx->blk_sub.hasargs) {
2260 AV* av = (AV*)PL_curpad[0];
2262 items = AvFILLp(av) + 1;
2264 /* Mark is at the end of the stack. */
2266 Copy(AvARRAY(av), SP + 1, items, SV*);
2271 #endif /* USE_THREADS */
2272 SAVESPTR(PL_curpad);
2273 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2275 if (cx->blk_sub.hasargs)
2276 #endif /* USE_THREADS */
2278 AV* av = (AV*)PL_curpad[0];
2282 cx->blk_sub.savearray = GvAV(PL_defgv);
2283 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2284 #endif /* USE_THREADS */
2285 cx->blk_sub.argarray = av;
2288 if (items >= AvMAX(av) + 1) {
2290 if (AvARRAY(av) != ary) {
2291 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2292 SvPVX(av) = (char*)ary;
2294 if (items >= AvMAX(av) + 1) {
2295 AvMAX(av) = items - 1;
2296 Renew(ary,items+1,SV*);
2298 SvPVX(av) = (char*)ary;
2301 Copy(mark,AvARRAY(av),items,SV*);
2302 AvFILLp(av) = items - 1;
2303 /* preserve @_ nature */
2314 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2316 * We do not care about using sv to call CV;
2317 * it's for informational purposes only.
2319 SV *sv = GvSV(PL_DBsub);
2322 if (PERLDB_SUB_NN) {
2323 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2326 gv_efullname3(sv, CvGV(cv), Nullch);
2329 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2330 PUSHMARK( PL_stack_sp );
2331 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2335 RETURNOP(CvSTART(cv));
2339 label = SvPV(sv,n_a);
2340 if (!(do_dump || *label))
2341 DIE(aTHX_ must_have_label);
2344 else if (PL_op->op_flags & OPf_SPECIAL) {
2346 DIE(aTHX_ must_have_label);
2349 label = cPVOP->op_pv;
2351 if (label && *label) {
2356 PL_lastgotoprobe = 0;
2358 for (ix = cxstack_ix; ix >= 0; ix--) {
2360 switch (CxTYPE(cx)) {
2362 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2365 gotoprobe = cx->blk_oldcop->op_sibling;
2371 gotoprobe = cx->blk_oldcop->op_sibling;
2373 gotoprobe = PL_main_root;
2376 if (CvDEPTH(cx->blk_sub.cv)) {
2377 gotoprobe = CvROOT(cx->blk_sub.cv);
2382 DIE(aTHX_ "Can't \"goto\" outside a block");
2385 DIE(aTHX_ "panic: goto");
2386 gotoprobe = PL_main_root;
2389 retop = dofindlabel(gotoprobe, label,
2390 enterops, enterops + GOTO_DEPTH);
2393 PL_lastgotoprobe = gotoprobe;
2396 DIE(aTHX_ "Can't find label %s", label);
2398 /* pop unwanted frames */
2400 if (ix < cxstack_ix) {
2407 oldsave = PL_scopestack[PL_scopestack_ix];
2408 LEAVE_SCOPE(oldsave);
2411 /* push wanted frames */
2413 if (*enterops && enterops[1]) {
2415 for (ix = 1; enterops[ix]; ix++) {
2416 PL_op = enterops[ix];
2417 /* Eventually we may want to stack the needed arguments
2418 * for each op. For now, we punt on the hard ones. */
2419 if (PL_op->op_type == OP_ENTERITER)
2420 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2422 (CALLOP->op_ppaddr)(aTHX);
2430 if (!retop) retop = PL_main_start;
2432 PL_restartop = retop;
2433 PL_do_undump = TRUE;
2437 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2438 PL_do_undump = FALSE;
2454 if (anum == 1 && VMSISH_EXIT)
2459 PUSHs(&PL_sv_undef);
2467 double value = SvNVx(GvSV(cCOP->cop_gv));
2468 register I32 match = I_32(value);
2471 if (((double)match) > value)
2472 --match; /* was fractional--truncate other way */
2474 match -= cCOP->uop.scop.scop_offset;
2477 else if (match > cCOP->uop.scop.scop_max)
2478 match = cCOP->uop.scop.scop_max;
2479 PL_op = cCOP->uop.scop.scop_next[match];
2489 PL_op = PL_op->op_next; /* can't assume anything */
2492 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2493 match -= cCOP->uop.scop.scop_offset;
2496 else if (match > cCOP->uop.scop.scop_max)
2497 match = cCOP->uop.scop.scop_max;
2498 PL_op = cCOP->uop.scop.scop_next[match];
2507 S_save_lines(pTHX_ AV *array, SV *sv)
2509 register char *s = SvPVX(sv);
2510 register char *send = SvPVX(sv) + SvCUR(sv);
2512 register I32 line = 1;
2514 while (s && s < send) {
2515 SV *tmpstr = NEWSV(85,0);
2517 sv_upgrade(tmpstr, SVt_PVMG);
2518 t = strchr(s, '\n');
2524 sv_setpvn(tmpstr, s, t - s);
2525 av_store(array, line++, tmpstr);
2531 S_docatch_body(pTHX_ va_list args)
2538 S_docatch(pTHX_ OP *o)
2545 assert(CATCH_GET == TRUE);
2549 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_docatch_body));
2555 PL_op = PL_restartop;
2570 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2571 /* sv Text to convert to OP tree. */
2572 /* startop op_free() this to undo. */
2573 /* code Short string id of the caller. */
2575 dSP; /* Make POPBLOCK work. */
2578 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2581 OP *oop = PL_op, *rop;
2582 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2588 /* switch to eval mode */
2590 if (PL_curcop == &PL_compiling) {
2591 SAVESPTR(PL_compiling.cop_stash);
2592 PL_compiling.cop_stash = PL_curstash;
2594 SAVESPTR(PL_compiling.cop_filegv);
2595 SAVEI16(PL_compiling.cop_line);
2596 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2597 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2598 PL_compiling.cop_line = 1;
2599 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2600 deleting the eval's FILEGV from the stash before gv_check() runs
2601 (i.e. before run-time proper). To work around the coredump that
2602 ensues, we always turn GvMULTI_on for any globals that were
2603 introduced within evals. See force_ident(). GSAR 96-10-12 */
2604 safestr = savepv(tmpbuf);
2605 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2607 #ifdef OP_IN_REGISTER
2615 PL_op->op_type = OP_ENTEREVAL;
2616 PL_op->op_flags = 0; /* Avoid uninit warning. */
2617 PUSHBLOCK(cx, CXt_EVAL, SP);
2618 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2619 rop = doeval(G_SCALAR, startop);
2620 POPBLOCK(cx,PL_curpm);
2623 (*startop)->op_type = OP_NULL;
2624 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2626 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2628 if (PL_curcop == &PL_compiling)
2629 PL_compiling.op_private = PL_hints;
2630 #ifdef OP_IN_REGISTER
2636 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2638 S_doeval(pTHX_ int gimme, OP** startop)
2647 PL_in_eval = EVAL_INEVAL;
2651 /* set up a scratch pad */
2654 SAVESPTR(PL_curpad);
2655 SAVESPTR(PL_comppad);
2656 SAVESPTR(PL_comppad_name);
2657 SAVEI32(PL_comppad_name_fill);
2658 SAVEI32(PL_min_intro_pending);
2659 SAVEI32(PL_max_intro_pending);
2662 for (i = cxstack_ix - 1; i >= 0; i--) {
2663 PERL_CONTEXT *cx = &cxstack[i];
2664 if (CxTYPE(cx) == CXt_EVAL)
2666 else if (CxTYPE(cx) == CXt_SUB) {
2667 caller = cx->blk_sub.cv;
2672 SAVESPTR(PL_compcv);
2673 PL_compcv = (CV*)NEWSV(1104,0);
2674 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2675 CvEVAL_on(PL_compcv);
2677 CvOWNER(PL_compcv) = 0;
2678 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2679 MUTEX_INIT(CvMUTEXP(PL_compcv));
2680 #endif /* USE_THREADS */
2682 PL_comppad = newAV();
2683 av_push(PL_comppad, Nullsv);
2684 PL_curpad = AvARRAY(PL_comppad);
2685 PL_comppad_name = newAV();
2686 PL_comppad_name_fill = 0;
2687 PL_min_intro_pending = 0;
2690 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2691 PL_curpad[0] = (SV*)newAV();
2692 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2693 #endif /* USE_THREADS */
2695 comppadlist = newAV();
2696 AvREAL_off(comppadlist);
2697 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2698 av_store(comppadlist, 1, (SV*)PL_comppad);
2699 CvPADLIST(PL_compcv) = comppadlist;
2701 if (!saveop || saveop->op_type != OP_REQUIRE)
2702 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2704 SAVEFREESV(PL_compcv);
2706 /* make sure we compile in the right package */
2708 newstash = PL_curcop->cop_stash;
2709 if (PL_curstash != newstash) {
2710 SAVESPTR(PL_curstash);
2711 PL_curstash = newstash;
2713 SAVESPTR(PL_beginav);
2714 PL_beginav = newAV();
2715 SAVEFREESV(PL_beginav);
2717 /* try to compile it */
2719 PL_eval_root = Nullop;
2721 PL_curcop = &PL_compiling;
2722 PL_curcop->cop_arybase = 0;
2723 SvREFCNT_dec(PL_rs);
2724 PL_rs = newSVpvn("\n", 1);
2725 if (saveop && saveop->op_flags & OPf_SPECIAL)
2726 PL_in_eval |= EVAL_KEEPERR;
2729 if (yyparse() || PL_error_count || !PL_eval_root) {
2733 I32 optype = 0; /* Might be reset by POPEVAL. */
2738 op_free(PL_eval_root);
2739 PL_eval_root = Nullop;
2741 SP = PL_stack_base + POPMARK; /* pop original mark */
2743 POPBLOCK(cx,PL_curpm);
2749 if (optype == OP_REQUIRE) {
2750 char* msg = SvPVx(ERRSV, n_a);
2751 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
2752 } else if (startop) {
2753 char* msg = SvPVx(ERRSV, n_a);
2755 POPBLOCK(cx,PL_curpm);
2757 Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2759 SvREFCNT_dec(PL_rs);
2760 PL_rs = SvREFCNT_inc(PL_nrs);
2762 MUTEX_LOCK(&PL_eval_mutex);
2764 COND_SIGNAL(&PL_eval_cond);
2765 MUTEX_UNLOCK(&PL_eval_mutex);
2766 #endif /* USE_THREADS */
2769 SvREFCNT_dec(PL_rs);
2770 PL_rs = SvREFCNT_inc(PL_nrs);
2771 PL_compiling.cop_line = 0;
2773 *startop = PL_eval_root;
2774 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2775 CvOUTSIDE(PL_compcv) = Nullcv;
2777 SAVEFREEOP(PL_eval_root);
2779 scalarvoid(PL_eval_root);
2780 else if (gimme & G_ARRAY)
2783 scalar(PL_eval_root);
2785 DEBUG_x(dump_eval());
2787 /* Register with debugger: */
2788 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2789 CV *cv = get_cv("DB::postponed", FALSE);
2793 XPUSHs((SV*)PL_compiling.cop_filegv);
2795 call_sv((SV*)cv, G_DISCARD);
2799 /* compiled okay, so do it */
2801 CvDEPTH(PL_compcv) = 1;
2802 SP = PL_stack_base + POPMARK; /* pop original mark */
2803 PL_op = saveop; /* The caller may need it. */
2805 MUTEX_LOCK(&PL_eval_mutex);
2807 COND_SIGNAL(&PL_eval_cond);
2808 MUTEX_UNLOCK(&PL_eval_mutex);
2809 #endif /* USE_THREADS */
2811 RETURNOP(PL_eval_start);
2815 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2817 STRLEN namelen = strlen(name);
2820 if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
2821 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2822 char *pmc = SvPV_nolen(pmcsv);
2825 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2826 fp = PerlIO_open(name, mode);
2829 if (PerlLIO_stat(name, &pmstat) < 0 ||
2830 pmstat.st_mtime < pmcstat.st_mtime)
2832 fp = PerlIO_open(pmc, mode);
2835 fp = PerlIO_open(name, mode);
2838 SvREFCNT_dec(pmcsv);
2841 fp = PerlIO_open(name, mode);
2849 register PERL_CONTEXT *cx;
2854 SV *namesv = Nullsv;
2856 I32 gimme = G_SCALAR;
2857 PerlIO *tryrsfp = 0;
2861 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2862 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2863 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2864 SvPV(sv,n_a),PL_patchlevel);
2867 name = SvPV(sv, len);
2868 if (!(name && len > 0 && *name))
2869 DIE(aTHX_ "Null filename used");
2870 TAINT_PROPER("require");
2871 if (PL_op->op_type == OP_REQUIRE &&
2872 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2873 *svp != &PL_sv_undef)
2876 /* prepare to compile file */
2881 (name[1] == '.' && name[2] == '/')))
2883 || (name[0] && name[1] == ':')
2886 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2889 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2890 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2895 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2898 AV *ar = GvAVn(PL_incgv);
2902 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2905 namesv = NEWSV(806, 0);
2906 for (i = 0; i <= AvFILL(ar); i++) {
2907 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2910 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2912 sv_setpv(namesv, unixdir);
2913 sv_catpv(namesv, unixname);
2915 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2917 TAINT_PROPER("require");
2918 tryname = SvPVX(namesv);
2919 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2921 if (tryname[0] == '.' && tryname[1] == '/')
2928 SAVESPTR(PL_compiling.cop_filegv);
2929 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2930 SvREFCNT_dec(namesv);
2932 if (PL_op->op_type == OP_REQUIRE) {
2933 char *msgstr = name;
2934 if (namesv) { /* did we lookup @INC? */
2935 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2936 SV *dirmsgsv = NEWSV(0, 0);
2937 AV *ar = GvAVn(PL_incgv);
2939 sv_catpvn(msg, " in @INC", 8);
2940 if (instr(SvPVX(msg), ".h "))
2941 sv_catpv(msg, " (change .h to .ph maybe?)");
2942 if (instr(SvPVX(msg), ".ph "))
2943 sv_catpv(msg, " (did you run h2ph?)");
2944 sv_catpv(msg, " (@INC contains:");
2945 for (i = 0; i <= AvFILL(ar); i++) {
2946 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2947 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
2948 sv_catsv(msg, dirmsgsv);
2950 sv_catpvn(msg, ")", 1);
2951 SvREFCNT_dec(dirmsgsv);
2952 msgstr = SvPV_nolen(msg);
2954 DIE(aTHX_ "Can't locate %s", msgstr);
2960 SETERRNO(0, SS$_NORMAL);
2962 /* Assume success here to prevent recursive requirement. */
2963 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2964 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2968 lex_start(sv_2mortal(newSVpvn("",0)));
2969 SAVEGENERICSV(PL_rsfp_filters);
2970 PL_rsfp_filters = Nullav;
2973 name = savepv(name);
2977 SAVEPPTR(PL_compiling.cop_warnings);
2978 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2981 /* switch to eval mode */
2983 push_return(PL_op->op_next);
2984 PUSHBLOCK(cx, CXt_EVAL, SP);
2985 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2987 SAVEI16(PL_compiling.cop_line);
2988 PL_compiling.cop_line = 0;
2992 MUTEX_LOCK(&PL_eval_mutex);
2993 if (PL_eval_owner && PL_eval_owner != thr)
2994 while (PL_eval_owner)
2995 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2996 PL_eval_owner = thr;
2997 MUTEX_UNLOCK(&PL_eval_mutex);
2998 #endif /* USE_THREADS */
2999 return DOCATCH(doeval(G_SCALAR, NULL));
3004 return pp_require();
3010 register PERL_CONTEXT *cx;
3012 I32 gimme = GIMME_V, was = PL_sub_generation;
3013 char tmpbuf[TYPE_DIGITS(long) + 12];
3018 if (!SvPV(sv,len) || !len)
3020 TAINT_PROPER("eval");
3026 /* switch to eval mode */
3028 SAVESPTR(PL_compiling.cop_filegv);
3029 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3030 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3031 PL_compiling.cop_line = 1;
3032 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3033 deleting the eval's FILEGV from the stash before gv_check() runs
3034 (i.e. before run-time proper). To work around the coredump that
3035 ensues, we always turn GvMULTI_on for any globals that were
3036 introduced within evals. See force_ident(). GSAR 96-10-12 */
3037 safestr = savepv(tmpbuf);
3038 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3040 PL_hints = PL_op->op_targ;
3041 SAVEPPTR(PL_compiling.cop_warnings);
3042 if (PL_compiling.cop_warnings != WARN_ALL
3043 && PL_compiling.cop_warnings != WARN_NONE){
3044 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3045 SAVEFREESV(PL_compiling.cop_warnings) ;
3048 push_return(PL_op->op_next);
3049 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3050 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3052 /* prepare to compile string */
3054 if (PERLDB_LINE && PL_curstash != PL_debstash)
3055 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3058 MUTEX_LOCK(&PL_eval_mutex);
3059 if (PL_eval_owner && PL_eval_owner != thr)
3060 while (PL_eval_owner)
3061 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3062 PL_eval_owner = thr;
3063 MUTEX_UNLOCK(&PL_eval_mutex);
3064 #endif /* USE_THREADS */
3065 ret = doeval(gimme, NULL);
3066 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3067 && ret != PL_op->op_next) { /* Successive compilation. */
3068 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3070 return DOCATCH(ret);
3080 register PERL_CONTEXT *cx;
3082 U8 save_flags = PL_op -> op_flags;
3087 retop = pop_return();
3090 if (gimme == G_VOID)
3092 else if (gimme == G_SCALAR) {
3095 if (SvFLAGS(TOPs) & SVs_TEMP)
3098 *MARK = sv_mortalcopy(TOPs);
3102 *MARK = &PL_sv_undef;
3106 /* in case LEAVE wipes old return values */
3107 for (mark = newsp + 1; mark <= SP; mark++) {
3108 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3109 *mark = sv_mortalcopy(*mark);
3110 TAINT_NOT; /* Each item is independent */
3114 PL_curpm = newpm; /* Don't pop $1 et al till now */
3116 if (AvFILLp(PL_comppad_name) >= 0)
3120 assert(CvDEPTH(PL_compcv) == 1);
3122 CvDEPTH(PL_compcv) = 0;
3125 if (optype == OP_REQUIRE &&
3126 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3128 /* Unassume the success we assumed earlier. */
3129 char *name = cx->blk_eval.old_name;
3130 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3131 retop = Perl_die(aTHX_ "%s did not return a true value", name);
3132 /* die_where() did LEAVE, or we won't be here */
3136 if (!(save_flags & OPf_SPECIAL))
3146 register PERL_CONTEXT *cx;
3147 I32 gimme = GIMME_V;
3152 push_return(cLOGOP->op_other->op_next);
3153 PUSHBLOCK(cx, CXt_EVAL, SP);
3155 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3157 PL_in_eval = EVAL_INEVAL;
3160 return DOCATCH(PL_op->op_next);
3170 register PERL_CONTEXT *cx;
3178 if (gimme == G_VOID)
3180 else if (gimme == G_SCALAR) {
3183 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3186 *MARK = sv_mortalcopy(TOPs);
3190 *MARK = &PL_sv_undef;
3195 /* in case LEAVE wipes old return values */
3196 for (mark = newsp + 1; mark <= SP; mark++) {
3197 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3198 *mark = sv_mortalcopy(*mark);
3199 TAINT_NOT; /* Each item is independent */
3203 PL_curpm = newpm; /* Don't pop $1 et al till now */
3211 S_doparseform(pTHX_ SV *sv)
3214 register char *s = SvPV_force(sv, len);
3215 register char *send = s + len;
3216 register char *base;
3217 register I32 skipspaces = 0;
3220 bool postspace = FALSE;
3228 Perl_croak(aTHX_ "Null picture in formline");
3230 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3235 *fpc++ = FF_LINEMARK;
3236 noblank = repeat = FALSE;
3254 case ' ': case '\t':
3265 *fpc++ = FF_LITERAL;
3273 *fpc++ = skipspaces;
3277 *fpc++ = FF_NEWLINE;
3281 arg = fpc - linepc + 1;
3288 *fpc++ = FF_LINEMARK;
3289 noblank = repeat = FALSE;
3298 ischop = s[-1] == '^';
3304 arg = (s - base) - 1;
3306 *fpc++ = FF_LITERAL;
3315 *fpc++ = FF_LINEGLOB;
3317 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3318 arg = ischop ? 512 : 0;
3328 arg |= 256 + (s - f);
3330 *fpc++ = s - base; /* fieldsize for FETCH */
3331 *fpc++ = FF_DECIMAL;
3336 bool ismore = FALSE;
3339 while (*++s == '>') ;
3340 prespace = FF_SPACE;
3342 else if (*s == '|') {
3343 while (*++s == '|') ;
3344 prespace = FF_HALFSPACE;
3349 while (*++s == '<') ;
3352 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3356 *fpc++ = s - base; /* fieldsize for FETCH */
3358 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3376 { /* need to jump to the next word */
3378 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3379 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3380 s = SvPVX(sv) + SvCUR(sv) + z;
3382 Copy(fops, s, arg, U16);
3384 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3389 * The rest of this file was derived from source code contributed
3392 * NOTE: this code was derived from Tom Horsley's qsort replacement
3393 * and should not be confused with the original code.
3396 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3398 Permission granted to distribute under the same terms as perl which are
3401 This program is free software; you can redistribute it and/or modify
3402 it under the terms of either:
3404 a) the GNU General Public License as published by the Free
3405 Software Foundation; either version 1, or (at your option) any
3408 b) the "Artistic License" which comes with this Kit.
3410 Details on the perl license can be found in the perl source code which
3411 may be located via the www.perl.com web page.
3413 This is the most wonderfulest possible qsort I can come up with (and
3414 still be mostly portable) My (limited) tests indicate it consistently
3415 does about 20% fewer calls to compare than does the qsort in the Visual
3416 C++ library, other vendors may vary.
3418 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3419 others I invented myself (or more likely re-invented since they seemed
3420 pretty obvious once I watched the algorithm operate for a while).
3422 Most of this code was written while watching the Marlins sweep the Giants
3423 in the 1997 National League Playoffs - no Braves fans allowed to use this
3424 code (just kidding :-).
3426 I realize that if I wanted to be true to the perl tradition, the only
3427 comment in this file would be something like:
3429 ...they shuffled back towards the rear of the line. 'No, not at the
3430 rear!' the slave-driver shouted. 'Three files up. And stay there...
3432 However, I really needed to violate that tradition just so I could keep
3433 track of what happens myself, not to mention some poor fool trying to
3434 understand this years from now :-).
3437 /* ********************************************************** Configuration */
3439 #ifndef QSORT_ORDER_GUESS
3440 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3443 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3444 future processing - a good max upper bound is log base 2 of memory size
3445 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3446 safely be smaller than that since the program is taking up some space and
3447 most operating systems only let you grab some subset of contiguous
3448 memory (not to mention that you are normally sorting data larger than
3449 1 byte element size :-).
3451 #ifndef QSORT_MAX_STACK
3452 #define QSORT_MAX_STACK 32
3455 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3456 Anything bigger and we use qsort. If you make this too small, the qsort
3457 will probably break (or become less efficient), because it doesn't expect
3458 the middle element of a partition to be the same as the right or left -
3459 you have been warned).
3461 #ifndef QSORT_BREAK_EVEN
3462 #define QSORT_BREAK_EVEN 6
3465 /* ************************************************************* Data Types */
3467 /* hold left and right index values of a partition waiting to be sorted (the
3468 partition includes both left and right - right is NOT one past the end or
3469 anything like that).
3471 struct partition_stack_entry {
3474 #ifdef QSORT_ORDER_GUESS
3475 int qsort_break_even;
3479 /* ******************************************************* Shorthand Macros */
3481 /* Note that these macros will be used from inside the qsort function where
3482 we happen to know that the variable 'elt_size' contains the size of an
3483 array element and the variable 'temp' points to enough space to hold a
3484 temp element and the variable 'array' points to the array being sorted
3485 and 'compare' is the pointer to the compare routine.
3487 Also note that there are very many highly architecture specific ways
3488 these might be sped up, but this is simply the most generally portable
3489 code I could think of.
3492 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3495 #define qsort_cmp(elt1, elt2) \
3496 ((this->*compare)(array[elt1], array[elt2]))
3498 #define qsort_cmp(elt1, elt2) \
3499 ((*compare)(aTHX_ array[elt1], array[elt2]))
3502 #ifdef QSORT_ORDER_GUESS
3503 #define QSORT_NOTICE_SWAP swapped++;
3505 #define QSORT_NOTICE_SWAP
3508 /* swaps contents of array elements elt1, elt2.
3510 #define qsort_swap(elt1, elt2) \
3513 temp = array[elt1]; \
3514 array[elt1] = array[elt2]; \
3515 array[elt2] = temp; \
3518 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3519 elt3 and elt3 gets elt1.
3521 #define qsort_rotate(elt1, elt2, elt3) \
3524 temp = array[elt1]; \
3525 array[elt1] = array[elt2]; \
3526 array[elt2] = array[elt3]; \
3527 array[elt3] = temp; \
3530 /* ************************************************************ Debug stuff */
3537 return; /* good place to set a breakpoint */
3540 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3543 doqsort_all_asserts(
3547 int (*compare)(const void * elt1, const void * elt2),
3548 int pc_left, int pc_right, int u_left, int u_right)
3552 qsort_assert(pc_left <= pc_right);
3553 qsort_assert(u_right < pc_left);
3554 qsort_assert(pc_right < u_left);
3555 for (i = u_right + 1; i < pc_left; ++i) {
3556 qsort_assert(qsort_cmp(i, pc_left) < 0);
3558 for (i = pc_left; i < pc_right; ++i) {
3559 qsort_assert(qsort_cmp(i, pc_right) == 0);
3561 for (i = pc_right + 1; i < u_left; ++i) {
3562 qsort_assert(qsort_cmp(pc_right, i) < 0);
3566 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3567 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3568 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3572 #define qsort_assert(t) ((void)0)
3574 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3578 /* ****************************************************************** qsort */
3581 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3585 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3586 int next_stack_entry = 0;
3590 #ifdef QSORT_ORDER_GUESS
3591 int qsort_break_even;
3595 /* Make sure we actually have work to do.
3597 if (num_elts <= 1) {
3601 /* Setup the initial partition definition and fall into the sorting loop
3604 part_right = (int)(num_elts - 1);
3605 #ifdef QSORT_ORDER_GUESS
3606 qsort_break_even = QSORT_BREAK_EVEN;
3608 #define qsort_break_even QSORT_BREAK_EVEN
3611 if ((part_right - part_left) >= qsort_break_even) {
3612 /* OK, this is gonna get hairy, so lets try to document all the
3613 concepts and abbreviations and variables and what they keep
3616 pc: pivot chunk - the set of array elements we accumulate in the
3617 middle of the partition, all equal in value to the original
3618 pivot element selected. The pc is defined by:
3620 pc_left - the leftmost array index of the pc
3621 pc_right - the rightmost array index of the pc
3623 we start with pc_left == pc_right and only one element
3624 in the pivot chunk (but it can grow during the scan).
3626 u: uncompared elements - the set of elements in the partition
3627 we have not yet compared to the pivot value. There are two
3628 uncompared sets during the scan - one to the left of the pc
3629 and one to the right.
3631 u_right - the rightmost index of the left side's uncompared set
3632 u_left - the leftmost index of the right side's uncompared set
3634 The leftmost index of the left sides's uncompared set
3635 doesn't need its own variable because it is always defined
3636 by the leftmost edge of the whole partition (part_left). The
3637 same goes for the rightmost edge of the right partition
3640 We know there are no uncompared elements on the left once we
3641 get u_right < part_left and no uncompared elements on the
3642 right once u_left > part_right. When both these conditions
3643 are met, we have completed the scan of the partition.
3645 Any elements which are between the pivot chunk and the
3646 uncompared elements should be less than the pivot value on
3647 the left side and greater than the pivot value on the right
3648 side (in fact, the goal of the whole algorithm is to arrange
3649 for that to be true and make the groups of less-than and
3650 greater-then elements into new partitions to sort again).
3652 As you marvel at the complexity of the code and wonder why it
3653 has to be so confusing. Consider some of the things this level
3654 of confusion brings:
3656 Once I do a compare, I squeeze every ounce of juice out of it. I
3657 never do compare calls I don't have to do, and I certainly never
3660 I also never swap any elements unless I can prove there is a
3661 good reason. Many sort algorithms will swap a known value with
3662 an uncompared value just to get things in the right place (or
3663 avoid complexity :-), but that uncompared value, once it gets
3664 compared, may then have to be swapped again. A lot of the
3665 complexity of this code is due to the fact that it never swaps
3666 anything except compared values, and it only swaps them when the
3667 compare shows they are out of position.
3669 int pc_left, pc_right;
3670 int u_right, u_left;
3674 pc_left = ((part_left + part_right) / 2);
3676 u_right = pc_left - 1;
3677 u_left = pc_right + 1;
3679 /* Qsort works best when the pivot value is also the median value
3680 in the partition (unfortunately you can't find the median value
3681 without first sorting :-), so to give the algorithm a helping
3682 hand, we pick 3 elements and sort them and use the median value
3683 of that tiny set as the pivot value.
3685 Some versions of qsort like to use the left middle and right as
3686 the 3 elements to sort so they can insure the ends of the
3687 partition will contain values which will stop the scan in the
3688 compare loop, but when you have to call an arbitrarily complex
3689 routine to do a compare, its really better to just keep track of
3690 array index values to know when you hit the edge of the
3691 partition and avoid the extra compare. An even better reason to
3692 avoid using a compare call is the fact that you can drop off the
3693 edge of the array if someone foolishly provides you with an
3694 unstable compare function that doesn't always provide consistent
3697 So, since it is simpler for us to compare the three adjacent
3698 elements in the middle of the partition, those are the ones we
3699 pick here (conveniently pointed at by u_right, pc_left, and
3700 u_left). The values of the left, center, and right elements
3701 are refered to as l c and r in the following comments.
3704 #ifdef QSORT_ORDER_GUESS
3707 s = qsort_cmp(u_right, pc_left);
3710 s = qsort_cmp(pc_left, u_left);
3711 /* if l < c, c < r - already in order - nothing to do */
3713 /* l < c, c == r - already in order, pc grows */
3715 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3717 /* l < c, c > r - need to know more */
3718 s = qsort_cmp(u_right, u_left);
3720 /* l < c, c > r, l < r - swap c & r to get ordered */
3721 qsort_swap(pc_left, u_left);
3722 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3723 } else if (s == 0) {
3724 /* l < c, c > r, l == r - swap c&r, grow pc */
3725 qsort_swap(pc_left, u_left);
3727 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3729 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3730 qsort_rotate(pc_left, u_right, u_left);
3731 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3734 } else if (s == 0) {
3736 s = qsort_cmp(pc_left, u_left);
3738 /* l == c, c < r - already in order, grow pc */
3740 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3741 } else if (s == 0) {
3742 /* l == c, c == r - already in order, grow pc both ways */
3745 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3747 /* l == c, c > r - swap l & r, grow pc */
3748 qsort_swap(u_right, u_left);
3750 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3754 s = qsort_cmp(pc_left, u_left);
3756 /* l > c, c < r - need to know more */
3757 s = qsort_cmp(u_right, u_left);
3759 /* l > c, c < r, l < r - swap l & c to get ordered */
3760 qsort_swap(u_right, pc_left);
3761 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3762 } else if (s == 0) {
3763 /* l > c, c < r, l == r - swap l & c, grow pc */
3764 qsort_swap(u_right, pc_left);
3766 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3768 /* l > c, c < r, l > r - rotate lcr into crl to order */
3769 qsort_rotate(u_right, pc_left, u_left);
3770 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3772 } else if (s == 0) {
3773 /* l > c, c == r - swap ends, grow pc */
3774 qsort_swap(u_right, u_left);
3776 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3778 /* l > c, c > r - swap ends to get in order */
3779 qsort_swap(u_right, u_left);
3780 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3783 /* We now know the 3 middle elements have been compared and
3784 arranged in the desired order, so we can shrink the uncompared
3789 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3791 /* The above massive nested if was the simple part :-). We now have
3792 the middle 3 elements ordered and we need to scan through the
3793 uncompared sets on either side, swapping elements that are on
3794 the wrong side or simply shuffling equal elements around to get
3795 all equal elements into the pivot chunk.
3799 int still_work_on_left;
3800 int still_work_on_right;
3802 /* Scan the uncompared values on the left. If I find a value
3803 equal to the pivot value, move it over so it is adjacent to
3804 the pivot chunk and expand the pivot chunk. If I find a value
3805 less than the pivot value, then just leave it - its already
3806 on the correct side of the partition. If I find a greater
3807 value, then stop the scan.
3809 while (still_work_on_left = (u_right >= part_left)) {
3810 s = qsort_cmp(u_right, pc_left);
3813 } else if (s == 0) {
3815 if (pc_left != u_right) {
3816 qsort_swap(u_right, pc_left);
3822 qsort_assert(u_right < pc_left);
3823 qsort_assert(pc_left <= pc_right);
3824 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3825 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3828 /* Do a mirror image scan of uncompared values on the right
3830 while (still_work_on_right = (u_left <= part_right)) {
3831 s = qsort_cmp(pc_right, u_left);
3834 } else if (s == 0) {
3836 if (pc_right != u_left) {
3837 qsort_swap(pc_right, u_left);
3843 qsort_assert(u_left > pc_right);
3844 qsort_assert(pc_left <= pc_right);
3845 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3846 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3849 if (still_work_on_left) {
3850 /* I know I have a value on the left side which needs to be
3851 on the right side, but I need to know more to decide
3852 exactly the best thing to do with it.
3854 if (still_work_on_right) {
3855 /* I know I have values on both side which are out of
3856 position. This is a big win because I kill two birds
3857 with one swap (so to speak). I can advance the
3858 uncompared pointers on both sides after swapping both
3859 of them into the right place.
3861 qsort_swap(u_right, u_left);
3864 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3866 /* I have an out of position value on the left, but the
3867 right is fully scanned, so I "slide" the pivot chunk
3868 and any less-than values left one to make room for the
3869 greater value over on the right. If the out of position
3870 value is immediately adjacent to the pivot chunk (there
3871 are no less-than values), I can do that with a swap,
3872 otherwise, I have to rotate one of the less than values
3873 into the former position of the out of position value
3874 and the right end of the pivot chunk into the left end
3878 if (pc_left == u_right) {
3879 qsort_swap(u_right, pc_right);
3880 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3882 qsort_rotate(u_right, pc_left, pc_right);
3883 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3888 } else if (still_work_on_right) {
3889 /* Mirror image of complex case above: I have an out of
3890 position value on the right, but the left is fully
3891 scanned, so I need to shuffle things around to make room
3892 for the right value on the left.
3895 if (pc_right == u_left) {
3896 qsort_swap(u_left, pc_left);
3897 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3899 qsort_rotate(pc_right, pc_left, u_left);
3900 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3905 /* No more scanning required on either side of partition,
3906 break out of loop and figure out next set of partitions
3912 /* The elements in the pivot chunk are now in the right place. They
3913 will never move or be compared again. All I have to do is decide
3914 what to do with the stuff to the left and right of the pivot
3917 Notes on the QSORT_ORDER_GUESS ifdef code:
3919 1. If I just built these partitions without swapping any (or
3920 very many) elements, there is a chance that the elements are
3921 already ordered properly (being properly ordered will
3922 certainly result in no swapping, but the converse can't be
3925 2. A (properly written) insertion sort will run faster on
3926 already ordered data than qsort will.
3928 3. Perhaps there is some way to make a good guess about
3929 switching to an insertion sort earlier than partition size 6
3930 (for instance - we could save the partition size on the stack
3931 and increase the size each time we find we didn't swap, thus
3932 switching to insertion sort earlier for partitions with a
3933 history of not swapping).
3935 4. Naturally, if I just switch right away, it will make
3936 artificial benchmarks with pure ascending (or descending)
3937 data look really good, but is that a good reason in general?
3941 #ifdef QSORT_ORDER_GUESS
3943 #if QSORT_ORDER_GUESS == 1
3944 qsort_break_even = (part_right - part_left) + 1;
3946 #if QSORT_ORDER_GUESS == 2
3947 qsort_break_even *= 2;
3949 #if QSORT_ORDER_GUESS == 3
3950 int prev_break = qsort_break_even;
3951 qsort_break_even *= qsort_break_even;
3952 if (qsort_break_even < prev_break) {
3953 qsort_break_even = (part_right - part_left) + 1;
3957 qsort_break_even = QSORT_BREAK_EVEN;
3961 if (part_left < pc_left) {
3962 /* There are elements on the left which need more processing.
3963 Check the right as well before deciding what to do.
3965 if (pc_right < part_right) {
3966 /* We have two partitions to be sorted. Stack the biggest one
3967 and process the smallest one on the next iteration. This
3968 minimizes the stack height by insuring that any additional
3969 stack entries must come from the smallest partition which
3970 (because it is smallest) will have the fewest
3971 opportunities to generate additional stack entries.
3973 if ((part_right - pc_right) > (pc_left - part_left)) {
3974 /* stack the right partition, process the left */
3975 partition_stack[next_stack_entry].left = pc_right + 1;
3976 partition_stack[next_stack_entry].right = part_right;
3977 #ifdef QSORT_ORDER_GUESS
3978 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3980 part_right = pc_left - 1;
3982 /* stack the left partition, process the right */
3983 partition_stack[next_stack_entry].left = part_left;
3984 partition_stack[next_stack_entry].right = pc_left - 1;
3985 #ifdef QSORT_ORDER_GUESS
3986 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3988 part_left = pc_right + 1;
3990 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3993 /* The elements on the left are the only remaining elements
3994 that need sorting, arrange for them to be processed as the
3997 part_right = pc_left - 1;
3999 } else if (pc_right < part_right) {
4000 /* There is only one chunk on the right to be sorted, make it
4001 the new partition and loop back around.
4003 part_left = pc_right + 1;
4005 /* This whole partition wound up in the pivot chunk, so
4006 we need to get a new partition off the stack.
4008 if (next_stack_entry == 0) {
4009 /* the stack is empty - we are done */
4013 part_left = partition_stack[next_stack_entry].left;
4014 part_right = partition_stack[next_stack_entry].right;
4015 #ifdef QSORT_ORDER_GUESS
4016 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4020 /* This partition is too small to fool with qsort complexity, just
4021 do an ordinary insertion sort to minimize overhead.
4024 /* Assume 1st element is in right place already, and start checking
4025 at 2nd element to see where it should be inserted.
4027 for (i = part_left + 1; i <= part_right; ++i) {
4029 /* Scan (backwards - just in case 'i' is already in right place)
4030 through the elements already sorted to see if the ith element
4031 belongs ahead of one of them.
4033 for (j = i - 1; j >= part_left; --j) {
4034 if (qsort_cmp(i, j) >= 0) {
4035 /* i belongs right after j
4042 /* Looks like we really need to move some things
4046 for (k = i - 1; k >= j; --k)
4047 array[k + 1] = array[k];
4052 /* That partition is now sorted, grab the next one, or get out
4053 of the loop if there aren't any more.
4056 if (next_stack_entry == 0) {
4057 /* the stack is empty - we are done */
4061 part_left = partition_stack[next_stack_entry].left;
4062 part_right = partition_stack[next_stack_entry].right;
4063 #ifdef QSORT_ORDER_GUESS
4064 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4069 /* Believe it or not, the array is sorted at this point! */