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
35 static I32 sortcv(pTHXo_ SV *a, SV *b);
36 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
37 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
38 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
39 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
40 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
41 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
42 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
45 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
46 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
48 #define sv_cmp_static Perl_sv_cmp
49 #define sv_cmp_locale_static Perl_sv_cmp_locale
58 cxix = dopoptosub(cxstack_ix);
62 switch (cxstack[cxix].blk_gimme) {
79 /* XXXX Should store the old value to allow for tie/overload - and
80 restore in regcomp, where marked with XXXX. */
88 register PMOP *pm = (PMOP*)cLOGOP->op_other;
92 MAGIC *mg = Null(MAGIC*);
96 SV *sv = SvRV(tmpstr);
98 mg = mg_find(sv, 'r');
101 regexp *re = (regexp *)mg->mg_obj;
102 ReREFCNT_dec(pm->op_pmregexp);
103 pm->op_pmregexp = ReREFCNT_inc(re);
106 t = SvPV(tmpstr, len);
108 /* Check against the last compiled regexp. */
109 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
110 pm->op_pmregexp->prelen != len ||
111 memNE(pm->op_pmregexp->precomp, t, len))
113 if (pm->op_pmregexp) {
114 ReREFCNT_dec(pm->op_pmregexp);
115 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
117 if (PL_op->op_flags & OPf_SPECIAL)
118 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
120 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
121 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
122 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
123 inside tie/overload accessors. */
127 #ifndef INCOMPLETE_TAINTS
130 pm->op_pmdynflags |= PMdf_TAINTED;
132 pm->op_pmdynflags &= ~PMdf_TAINTED;
136 if (!pm->op_pmregexp->prelen && PL_curpm)
138 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
139 pm->op_pmflags |= PMf_WHITE;
141 if (pm->op_pmflags & PMf_KEEP) {
142 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
143 cLOGOP->op_first->op_next = PL_op->op_next;
151 register PMOP *pm = (PMOP*) cLOGOP->op_other;
152 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
153 register SV *dstr = cx->sb_dstr;
154 register char *s = cx->sb_s;
155 register char *m = cx->sb_m;
156 char *orig = cx->sb_orig;
157 register REGEXP *rx = cx->sb_rx;
159 rxres_restore(&cx->sb_rxres, rx);
161 if (cx->sb_iters++) {
162 if (cx->sb_iters > cx->sb_maxiters)
163 DIE(aTHX_ "Substitution loop");
165 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
166 cx->sb_rxtainted |= 2;
167 sv_catsv(dstr, POPs);
170 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
171 s == m, cx->sb_targ, NULL,
172 ((cx->sb_rflags & REXEC_COPY_STR)
173 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
174 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
176 SV *targ = cx->sb_targ;
177 sv_catpvn(dstr, s, cx->sb_strend - s);
179 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
181 (void)SvOOK_off(targ);
182 Safefree(SvPVX(targ));
183 SvPVX(targ) = SvPVX(dstr);
184 SvCUR_set(targ, SvCUR(dstr));
185 SvLEN_set(targ, SvLEN(dstr));
189 TAINT_IF(cx->sb_rxtainted & 1);
190 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
192 (void)SvPOK_only(targ);
193 TAINT_IF(cx->sb_rxtainted);
197 LEAVE_SCOPE(cx->sb_oldsave);
199 RETURNOP(pm->op_next);
202 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
205 cx->sb_orig = orig = rx->subbeg;
207 cx->sb_strend = s + (cx->sb_strend - m);
209 cx->sb_m = m = rx->startp[0] + orig;
210 sv_catpvn(dstr, s, m-s);
211 cx->sb_s = rx->endp[0] + orig;
212 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
213 rxres_save(&cx->sb_rxres, rx);
214 RETURNOP(pm->op_pmreplstart);
218 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
223 if (!p || p[1] < rx->nparens) {
224 i = 6 + rx->nparens * 2;
232 *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
233 RX_MATCH_COPIED_off(rx);
237 *p++ = (UV)rx->subbeg;
238 *p++ = (UV)rx->sublen;
239 for (i = 0; i <= rx->nparens; ++i) {
240 *p++ = (UV)rx->startp[i];
241 *p++ = (UV)rx->endp[i];
246 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
251 if (RX_MATCH_COPIED(rx))
252 Safefree(rx->subbeg);
253 RX_MATCH_COPIED_set(rx, *p);
258 rx->subbeg = (char*)(*p++);
259 rx->sublen = (I32)(*p++);
260 for (i = 0; i <= rx->nparens; ++i) {
261 rx->startp[i] = (I32)(*p++);
262 rx->endp[i] = (I32)(*p++);
267 Perl_rxres_free(pTHX_ void **rsp)
272 Safefree((char*)(*p));
280 djSP; dMARK; dORIGMARK;
281 register SV *tmpForm = *++MARK;
293 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
299 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
301 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
302 SvREADONLY_off(tmpForm);
303 doparseform(tmpForm);
306 SvPV_force(PL_formtarget, len);
307 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
309 f = SvPV(tmpForm, len);
310 /* need to jump to the next word */
311 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
320 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
321 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
322 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
323 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
324 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
326 case FF_CHECKNL: name = "CHECKNL"; break;
327 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
328 case FF_SPACE: name = "SPACE"; break;
329 case FF_HALFSPACE: name = "HALFSPACE"; break;
330 case FF_ITEM: name = "ITEM"; break;
331 case FF_CHOP: name = "CHOP"; break;
332 case FF_LINEGLOB: name = "LINEGLOB"; break;
333 case FF_NEWLINE: name = "NEWLINE"; break;
334 case FF_MORE: name = "MORE"; break;
335 case FF_LINEMARK: name = "LINEMARK"; break;
336 case FF_END: name = "END"; break;
339 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
341 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
369 if (ckWARN(WARN_SYNTAX))
370 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
375 item = s = SvPV(sv, len);
378 itemsize = sv_len_utf8(sv);
379 if (itemsize != len) {
381 if (itemsize > fieldsize) {
382 itemsize = fieldsize;
383 itembytes = itemsize;
384 sv_pos_u2b(sv, &itembytes, 0);
388 send = chophere = s + itembytes;
397 sv_pos_b2u(sv, &itemsize);
401 if (itemsize > fieldsize)
402 itemsize = fieldsize;
403 send = chophere = s + itemsize;
415 item = s = SvPV(sv, len);
418 itemsize = sv_len_utf8(sv);
419 if (itemsize != len) {
421 if (itemsize <= fieldsize) {
422 send = chophere = s + itemsize;
433 itemsize = fieldsize;
434 itembytes = itemsize;
435 sv_pos_u2b(sv, &itembytes, 0);
436 send = chophere = s + itembytes;
437 while (s < send || (s == send && isSPACE(*s))) {
447 if (strchr(PL_chopset, *s))
452 itemsize = chophere - item;
453 sv_pos_b2u(sv, &itemsize);
458 if (itemsize <= fieldsize) {
459 send = chophere = s + itemsize;
470 itemsize = fieldsize;
471 send = chophere = s + itemsize;
472 while (s < send || (s == send && isSPACE(*s))) {
482 if (strchr(PL_chopset, *s))
487 itemsize = chophere - item;
492 arg = fieldsize - itemsize;
501 arg = fieldsize - itemsize;
516 switch (UTF8SKIP(s)) {
527 if ( !((*t++ = *s++) & ~31) )
535 int ch = *t++ = *s++;
538 if ( !((*t++ = *s++) & ~31) )
547 while (*s && isSPACE(*s))
554 item = s = SvPV(sv, len);
567 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
568 sv_catpvn(PL_formtarget, item, itemsize);
569 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
570 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
575 /* If the field is marked with ^ and the value is undefined,
578 if ((arg & 512) && !SvOK(sv)) {
586 /* Formats aren't yet marked for locales, so assume "yes". */
588 RESTORE_NUMERIC_LOCAL();
589 #if defined(USE_LONG_DOUBLE)
591 sprintf(t, "%#*.*" PERL_PRIfldbl,
592 (int) fieldsize, (int) arg & 255, value);
594 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
599 (int) fieldsize, (int) arg & 255, value);
602 (int) fieldsize, value);
605 RESTORE_NUMERIC_STANDARD();
612 while (t-- > linemark && *t == ' ') ;
620 if (arg) { /* repeat until fields exhausted? */
622 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
623 lines += FmLINES(PL_formtarget);
626 if (strnEQ(linemark, linemark - arg, arg))
627 DIE(aTHX_ "Runaway format");
629 FmLINES(PL_formtarget) = lines;
631 RETURNOP(cLISTOP->op_first);
644 while (*s && isSPACE(*s) && s < send)
648 arg = fieldsize - itemsize;
655 if (strnEQ(s," ",3)) {
656 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
667 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
668 FmLINES(PL_formtarget) += lines;
680 if (PL_stack_base + *PL_markstack_ptr == SP) {
682 if (GIMME_V == G_SCALAR)
683 XPUSHs(sv_2mortal(newSViv(0)));
684 RETURNOP(PL_op->op_next->op_next);
686 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
687 pp_pushmark(); /* push dst */
688 pp_pushmark(); /* push src */
689 ENTER; /* enter outer scope */
692 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
694 ENTER; /* enter inner scope */
697 src = PL_stack_base[*PL_markstack_ptr];
702 if (PL_op->op_type == OP_MAPSTART)
703 pp_pushmark(); /* push top */
704 return ((LOGOP*)PL_op->op_next)->op_other;
709 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
715 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
721 ++PL_markstack_ptr[-1];
723 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
724 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
725 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
730 PL_markstack_ptr[-1] += shift;
731 *PL_markstack_ptr += shift;
735 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
738 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
740 LEAVE; /* exit inner scope */
743 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
747 (void)POPMARK; /* pop top */
748 LEAVE; /* exit outer scope */
749 (void)POPMARK; /* pop src */
750 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
751 (void)POPMARK; /* pop dst */
752 SP = PL_stack_base + POPMARK; /* pop original mark */
753 if (gimme == G_SCALAR) {
757 else if (gimme == G_ARRAY)
764 ENTER; /* enter inner scope */
767 src = PL_stack_base[PL_markstack_ptr[-1]];
771 RETURNOP(cLOGOP->op_other);
777 djSP; dMARK; dORIGMARK;
779 SV **myorigmark = ORIGMARK;
785 OP* nextop = PL_op->op_next;
788 if (gimme != G_ARRAY) {
794 SAVEPPTR(PL_sortcop);
795 if (PL_op->op_flags & OPf_STACKED) {
796 if (PL_op->op_flags & OPf_SPECIAL) {
797 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
798 kid = kUNOP->op_first; /* pass rv2gv */
799 kid = kUNOP->op_first; /* pass leave */
800 PL_sortcop = kid->op_next;
801 stash = PL_curcop->cop_stash;
804 cv = sv_2cv(*++MARK, &stash, &gv, 0);
805 if (!(cv && CvROOT(cv))) {
807 SV *tmpstr = sv_newmortal();
808 gv_efullname3(tmpstr, gv, Nullch);
809 if (cv && CvXSUB(cv))
810 DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
811 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
816 DIE(aTHX_ "Xsub called in sort");
817 DIE(aTHX_ "Undefined subroutine in sort");
819 DIE(aTHX_ "Not a CODE reference in sort");
821 PL_sortcop = CvSTART(cv);
822 SAVESPTR(CvROOT(cv)->op_ppaddr);
823 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
826 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
831 stash = PL_curcop->cop_stash;
835 while (MARK < SP) { /* This may or may not shift down one here. */
837 if (*up = *++MARK) { /* Weed out nulls. */
839 if (!PL_sortcop && !SvPOK(*up)) {
844 (void)sv_2pv(*up, &n_a);
849 max = --up - myorigmark;
854 bool oldcatch = CATCH_GET;
860 PUSHSTACKi(PERLSI_SORT);
861 if (PL_sortstash != stash) {
862 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
863 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
864 PL_sortstash = stash;
867 SAVESPTR(GvSV(PL_firstgv));
868 SAVESPTR(GvSV(PL_secondgv));
870 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
871 if (!(PL_op->op_flags & OPf_SPECIAL)) {
872 bool hasargs = FALSE;
873 cx->cx_type = CXt_SUB;
874 cx->blk_gimme = G_SCALAR;
877 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
879 PL_sortcxix = cxstack_ix;
880 qsortsv((myorigmark+1), max, sortcv);
882 POPBLOCK(cx,PL_curpm);
890 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
891 qsortsv(ORIGMARK+1, max,
892 (PL_op->op_private & OPpSORT_NUMERIC)
893 ? ( (PL_op->op_private & OPpSORT_INTEGER)
894 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
895 : ( overloading ? amagic_ncmp : sv_ncmp))
896 : ( (PL_op->op_private & OPpLOCALE)
899 : sv_cmp_locale_static)
900 : ( overloading ? amagic_cmp : sv_cmp_static)));
901 if (PL_op->op_private & OPpSORT_REVERSE) {
903 SV **q = ORIGMARK+max;
913 PL_stack_sp = ORIGMARK + max;
921 if (GIMME == G_ARRAY)
923 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
924 return cLOGOP->op_other;
933 if (GIMME == G_ARRAY) {
934 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
938 SV *targ = PAD_SV(PL_op->op_targ);
940 if ((PL_op->op_private & OPpFLIP_LINENUM)
941 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
943 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
944 if (PL_op->op_flags & OPf_SPECIAL) {
952 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
965 if (GIMME == G_ARRAY) {
971 if (SvGMAGICAL(left))
973 if (SvGMAGICAL(right))
976 if (SvNIOKp(left) || !SvPOKp(left) ||
977 (looks_like_number(left) && *SvPVX(left) != '0') )
979 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
980 Perl_croak(aTHX_ "Range iterator outside integer range");
991 sv = sv_2mortal(newSViv(i++));
996 SV *final = sv_mortalcopy(right);
998 char *tmps = SvPV(final, len);
1000 sv = sv_mortalcopy(left);
1002 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1004 if (strEQ(SvPVX(sv),tmps))
1006 sv = sv_2mortal(newSVsv(sv));
1013 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1015 if ((PL_op->op_private & OPpFLIP_LINENUM)
1016 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1018 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1019 sv_catpv(targ, "E0");
1030 S_dopoptolabel(pTHX_ char *label)
1034 register PERL_CONTEXT *cx;
1036 for (i = cxstack_ix; i >= 0; i--) {
1038 switch (CxTYPE(cx)) {
1040 if (ckWARN(WARN_UNSAFE))
1041 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1042 PL_op_name[PL_op->op_type]);
1045 if (ckWARN(WARN_UNSAFE))
1046 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1047 PL_op_name[PL_op->op_type]);
1050 if (ckWARN(WARN_UNSAFE))
1051 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1052 PL_op_name[PL_op->op_type]);
1055 if (ckWARN(WARN_UNSAFE))
1056 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1057 PL_op_name[PL_op->op_type]);
1060 if (!cx->blk_loop.label ||
1061 strNE(label, cx->blk_loop.label) ) {
1062 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1063 (long)i, cx->blk_loop.label));
1066 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1074 Perl_dowantarray(pTHX)
1076 I32 gimme = block_gimme();
1077 return (gimme == G_VOID) ? G_SCALAR : gimme;
1081 Perl_block_gimme(pTHX)
1086 cxix = dopoptosub(cxstack_ix);
1090 switch (cxstack[cxix].blk_gimme) {
1098 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1105 S_dopoptosub(pTHX_ I32 startingblock)
1108 return dopoptosub_at(cxstack, startingblock);
1112 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1116 register PERL_CONTEXT *cx;
1117 for (i = startingblock; i >= 0; i--) {
1119 switch (CxTYPE(cx)) {
1124 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1132 S_dopoptoeval(pTHX_ I32 startingblock)
1136 register PERL_CONTEXT *cx;
1137 for (i = startingblock; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1143 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1151 S_dopoptoloop(pTHX_ I32 startingblock)
1155 register PERL_CONTEXT *cx;
1156 for (i = startingblock; i >= 0; i--) {
1158 switch (CxTYPE(cx)) {
1160 if (ckWARN(WARN_UNSAFE))
1161 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1162 PL_op_name[PL_op->op_type]);
1165 if (ckWARN(WARN_UNSAFE))
1166 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1167 PL_op_name[PL_op->op_type]);
1170 if (ckWARN(WARN_UNSAFE))
1171 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1172 PL_op_name[PL_op->op_type]);
1175 if (ckWARN(WARN_UNSAFE))
1176 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1177 PL_op_name[PL_op->op_type]);
1180 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1188 Perl_dounwind(pTHX_ I32 cxix)
1191 register PERL_CONTEXT *cx;
1195 while (cxstack_ix > cxix) {
1196 cx = &cxstack[cxstack_ix];
1197 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1198 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1199 /* Note: we don't need to restore the base context info till the end. */
1200 switch (CxTYPE(cx)) {
1203 continue; /* not break */
1221 * Closures mentioned at top level of eval cannot be referenced
1222 * again, and their presence indirectly causes a memory leak.
1223 * (Note that the fact that compcv and friends are still set here
1224 * is, AFAIK, an accident.) --Chip
1226 * XXX need to get comppad et al from eval's cv rather than
1227 * relying on the incidental global values.
1230 S_free_closures(pTHX)
1233 SV **svp = AvARRAY(PL_comppad_name);
1235 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1237 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1239 svp[ix] = &PL_sv_undef;
1243 SvREFCNT_dec(CvOUTSIDE(sv));
1244 CvOUTSIDE(sv) = Nullcv;
1257 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1263 register PERL_CONTEXT *cx;
1268 if (PL_in_eval & EVAL_KEEPERR) {
1271 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1274 static char prefix[] = "\t(in cleanup) ";
1276 sv_upgrade(*svp, SVt_IV);
1277 (void)SvIOK_only(*svp);
1280 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1281 sv_catpvn(err, prefix, sizeof(prefix)-1);
1282 sv_catpvn(err, message, msglen);
1283 if (ckWARN(WARN_UNSAFE)) {
1284 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1285 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1292 sv_setpvn(ERRSV, message, msglen);
1295 message = SvPVx(ERRSV, msglen);
1297 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1305 if (cxix < cxstack_ix)
1308 POPBLOCK(cx,PL_curpm);
1309 if (CxTYPE(cx) != CXt_EVAL) {
1310 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1311 PerlIO_write(PerlIO_stderr(), message, msglen);
1316 if (gimme == G_SCALAR)
1317 *++newsp = &PL_sv_undef;
1318 PL_stack_sp = newsp;
1322 if (optype == OP_REQUIRE) {
1323 char* msg = SvPVx(ERRSV, n_a);
1324 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
1326 return pop_return();
1330 message = SvPVx(ERRSV, msglen);
1333 /* SFIO can really mess with your errno */
1336 PerlIO_write(PerlIO_stderr(), message, msglen);
1337 (void)PerlIO_flush(PerlIO_stderr());
1350 if (SvTRUE(left) != SvTRUE(right))
1362 RETURNOP(cLOGOP->op_other);
1371 RETURNOP(cLOGOP->op_other);
1377 register I32 cxix = dopoptosub(cxstack_ix);
1378 register PERL_CONTEXT *cx;
1379 register PERL_CONTEXT *ccstack = cxstack;
1380 PERL_SI *top_si = PL_curstackinfo;
1391 /* we may be in a higher stacklevel, so dig down deeper */
1392 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1393 top_si = top_si->si_prev;
1394 ccstack = top_si->si_cxstack;
1395 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1398 if (GIMME != G_ARRAY)
1402 if (PL_DBsub && cxix >= 0 &&
1403 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1407 cxix = dopoptosub_at(ccstack, cxix - 1);
1410 cx = &ccstack[cxix];
1411 if (CxTYPE(cx) == CXt_SUB) {
1412 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1413 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1414 field below is defined for any cx. */
1415 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1416 cx = &ccstack[dbcxix];
1419 if (GIMME != G_ARRAY) {
1420 hv = cx->blk_oldcop->cop_stash;
1422 PUSHs(&PL_sv_undef);
1425 sv_setpv(TARG, HvNAME(hv));
1431 hv = cx->blk_oldcop->cop_stash;
1433 PUSHs(&PL_sv_undef);
1435 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1436 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1437 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1438 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1441 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1443 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1444 PUSHs(sv_2mortal(sv));
1445 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1448 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1449 PUSHs(sv_2mortal(newSViv(0)));
1451 gimme = (I32)cx->blk_gimme;
1452 if (gimme == G_VOID)
1453 PUSHs(&PL_sv_undef);
1455 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1456 if (CxTYPE(cx) == CXt_EVAL) {
1457 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1458 PUSHs(cx->blk_eval.cur_text);
1461 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1462 /* Require, put the name. */
1463 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1468 PUSHs(&PL_sv_undef);
1469 PUSHs(&PL_sv_undef);
1471 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1472 && PL_curcop->cop_stash == PL_debstash)
1474 AV *ary = cx->blk_sub.argarray;
1475 int off = AvARRAY(ary) - AvALLOC(ary);
1479 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1482 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1485 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1486 av_extend(PL_dbargs, AvFILLp(ary) + off);
1487 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1488 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1490 /* XXX only hints propagated via op_private are currently
1491 * visible (others are not easily accessible, since they
1492 * use the global PL_hints) */
1493 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1494 HINT_PRIVATE_MASK)));
1508 sv_reset(tmps, PL_curcop->cop_stash);
1520 PL_curcop = (COP*)PL_op;
1521 TAINT_NOT; /* Each statement is presumed innocent */
1522 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1525 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1529 register PERL_CONTEXT *cx;
1530 I32 gimme = G_ARRAY;
1537 DIE(aTHX_ "No DB::DB routine defined");
1539 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1551 push_return(PL_op->op_next);
1552 PUSHBLOCK(cx, CXt_SUB, SP);
1555 (void)SvREFCNT_inc(cv);
1556 SAVESPTR(PL_curpad);
1557 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1558 RETURNOP(CvSTART(cv));
1572 register PERL_CONTEXT *cx;
1573 I32 gimme = GIMME_V;
1580 if (PL_op->op_flags & OPf_SPECIAL) {
1582 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1583 SAVEGENERICSV(*svp);
1587 #endif /* USE_THREADS */
1588 if (PL_op->op_targ) {
1589 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1593 svp = &GvSV((GV*)POPs); /* symbol table variable */
1594 SAVEGENERICSV(*svp);
1600 PUSHBLOCK(cx, CXt_LOOP, SP);
1601 PUSHLOOP(cx, svp, MARK);
1602 if (PL_op->op_flags & OPf_STACKED) {
1603 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1604 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1606 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1607 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1608 if (SvNV(sv) < IV_MIN ||
1609 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1610 Perl_croak(aTHX_ "Range iterator outside integer range");
1611 cx->blk_loop.iterix = SvIV(sv);
1612 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1615 cx->blk_loop.iterlval = newSVsv(sv);
1619 cx->blk_loop.iterary = PL_curstack;
1620 AvFILLp(PL_curstack) = SP - PL_stack_base;
1621 cx->blk_loop.iterix = MARK - PL_stack_base;
1630 register PERL_CONTEXT *cx;
1631 I32 gimme = GIMME_V;
1637 PUSHBLOCK(cx, CXt_LOOP, SP);
1638 PUSHLOOP(cx, 0, SP);
1646 register PERL_CONTEXT *cx;
1647 struct block_loop cxloop;
1655 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1658 if (gimme == G_VOID)
1660 else if (gimme == G_SCALAR) {
1662 *++newsp = sv_mortalcopy(*SP);
1664 *++newsp = &PL_sv_undef;
1668 *++newsp = sv_mortalcopy(*++mark);
1669 TAINT_NOT; /* Each item is independent */
1675 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1676 PL_curpm = newpm; /* ... and pop $1 et al */
1688 register PERL_CONTEXT *cx;
1689 struct block_sub cxsub;
1690 bool popsub2 = FALSE;
1696 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1697 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1698 if (cxstack_ix > PL_sortcxix)
1699 dounwind(PL_sortcxix);
1700 AvARRAY(PL_curstack)[1] = *SP;
1701 PL_stack_sp = PL_stack_base + 1;
1706 cxix = dopoptosub(cxstack_ix);
1708 DIE(aTHX_ "Can't return outside a subroutine");
1709 if (cxix < cxstack_ix)
1713 switch (CxTYPE(cx)) {
1715 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1720 if (AvFILLp(PL_comppad_name) >= 0)
1723 if (optype == OP_REQUIRE &&
1724 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1726 /* Unassume the success we assumed earlier. */
1727 char *name = cx->blk_eval.old_name;
1728 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1729 DIE(aTHX_ "%s did not return a true value", name);
1733 DIE(aTHX_ "panic: return");
1737 if (gimme == G_SCALAR) {
1740 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1742 *++newsp = SvREFCNT_inc(*SP);
1747 *++newsp = sv_mortalcopy(*SP);
1750 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1752 *++newsp = sv_mortalcopy(*SP);
1754 *++newsp = &PL_sv_undef;
1756 else if (gimme == G_ARRAY) {
1757 while (++MARK <= SP) {
1758 *++newsp = (popsub2 && SvTEMP(*MARK))
1759 ? *MARK : sv_mortalcopy(*MARK);
1760 TAINT_NOT; /* Each item is independent */
1763 PL_stack_sp = newsp;
1765 /* Stack values are safe: */
1767 POPSUB2(); /* release CV and @_ ... */
1769 PL_curpm = newpm; /* ... and pop $1 et al */
1772 return pop_return();
1779 register PERL_CONTEXT *cx;
1780 struct block_loop cxloop;
1781 struct block_sub cxsub;
1788 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1790 if (PL_op->op_flags & OPf_SPECIAL) {
1791 cxix = dopoptoloop(cxstack_ix);
1793 DIE(aTHX_ "Can't \"last\" outside a block");
1796 cxix = dopoptolabel(cPVOP->op_pv);
1798 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1800 if (cxix < cxstack_ix)
1804 switch (CxTYPE(cx)) {
1806 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1808 nextop = cxloop.last_op->op_next;
1811 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1813 nextop = pop_return();
1817 nextop = pop_return();
1820 DIE(aTHX_ "panic: last");
1824 if (gimme == G_SCALAR) {
1826 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1827 ? *SP : sv_mortalcopy(*SP);
1829 *++newsp = &PL_sv_undef;
1831 else if (gimme == G_ARRAY) {
1832 while (++MARK <= SP) {
1833 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1834 ? *MARK : sv_mortalcopy(*MARK);
1835 TAINT_NOT; /* Each item is independent */
1841 /* Stack values are safe: */
1844 POPLOOP2(); /* release loop vars ... */
1848 POPSUB2(); /* release CV and @_ ... */
1851 PL_curpm = newpm; /* ... and pop $1 et al */
1860 register PERL_CONTEXT *cx;
1863 if (PL_op->op_flags & OPf_SPECIAL) {
1864 cxix = dopoptoloop(cxstack_ix);
1866 DIE(aTHX_ "Can't \"next\" outside a block");
1869 cxix = dopoptolabel(cPVOP->op_pv);
1871 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1873 if (cxix < cxstack_ix)
1877 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1878 LEAVE_SCOPE(oldsave);
1879 return cx->blk_loop.next_op;
1885 register PERL_CONTEXT *cx;
1888 if (PL_op->op_flags & OPf_SPECIAL) {
1889 cxix = dopoptoloop(cxstack_ix);
1891 DIE(aTHX_ "Can't \"redo\" outside a block");
1894 cxix = dopoptolabel(cPVOP->op_pv);
1896 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1898 if (cxix < cxstack_ix)
1902 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1903 LEAVE_SCOPE(oldsave);
1904 return cx->blk_loop.redo_op;
1908 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1912 static char too_deep[] = "Target of goto is too deeply nested";
1915 Perl_croak(aTHX_ too_deep);
1916 if (o->op_type == OP_LEAVE ||
1917 o->op_type == OP_SCOPE ||
1918 o->op_type == OP_LEAVELOOP ||
1919 o->op_type == OP_LEAVETRY)
1921 *ops++ = cUNOPo->op_first;
1923 Perl_croak(aTHX_ too_deep);
1926 if (o->op_flags & OPf_KIDS) {
1928 /* First try all the kids at this level, since that's likeliest. */
1929 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1930 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1931 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1934 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1935 if (kid == PL_lastgotoprobe)
1937 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1939 (ops[-1]->op_type != OP_NEXTSTATE &&
1940 ops[-1]->op_type != OP_DBSTATE)))
1942 if (o = dofindlabel(kid, label, ops, oplimit))
1961 register PERL_CONTEXT *cx;
1962 #define GOTO_DEPTH 64
1963 OP *enterops[GOTO_DEPTH];
1965 int do_dump = (PL_op->op_type == OP_DUMP);
1966 static char must_have_label[] = "goto must have label";
1969 if (PL_op->op_flags & OPf_STACKED) {
1973 /* This egregious kludge implements goto &subroutine */
1974 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1976 register PERL_CONTEXT *cx;
1977 CV* cv = (CV*)SvRV(sv);
1981 int arg_was_real = 0;
1984 if (!CvROOT(cv) && !CvXSUB(cv)) {
1989 /* autoloaded stub? */
1990 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1992 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1993 GvNAMELEN(gv), FALSE);
1994 if (autogv && (cv = GvCV(autogv)))
1996 tmpstr = sv_newmortal();
1997 gv_efullname3(tmpstr, gv, Nullch);
1998 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2000 DIE(aTHX_ "Goto undefined subroutine");
2003 /* First do some returnish stuff. */
2004 cxix = dopoptosub(cxstack_ix);
2006 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2007 if (cxix < cxstack_ix)
2010 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2011 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2013 if (CxTYPE(cx) == CXt_SUB &&
2014 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2015 AV* av = cx->blk_sub.argarray;
2017 items = AvFILLp(av) + 1;
2019 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2020 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2021 PL_stack_sp += items;
2023 SvREFCNT_dec(GvAV(PL_defgv));
2024 GvAV(PL_defgv) = cx->blk_sub.savearray;
2025 #endif /* USE_THREADS */
2028 AvREAL_off(av); /* so av_clear() won't clobber elts */
2032 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2036 av = (AV*)PL_curpad[0];
2038 av = GvAV(PL_defgv);
2040 items = AvFILLp(av) + 1;
2042 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2043 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2044 PL_stack_sp += items;
2046 if (CxTYPE(cx) == CXt_SUB &&
2047 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2048 SvREFCNT_dec(cx->blk_sub.cv);
2049 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2050 LEAVE_SCOPE(oldsave);
2052 /* Now do some callish stuff. */
2055 #ifdef PERL_XSUB_OLDSTYLE
2056 if (CvOLDSTYLE(cv)) {
2057 I32 (*fp3)(int,int,int);
2062 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2063 items = (*fp3)(CvXSUBANY(cv).any_i32,
2064 mark - PL_stack_base + 1,
2066 SP = PL_stack_base + items;
2069 #endif /* PERL_XSUB_OLDSTYLE */
2074 PL_stack_sp--; /* There is no cv arg. */
2075 /* Push a mark for the start of arglist */
2077 (void)(*CvXSUB(cv))(aTHXo_ cv);
2078 /* Pop the current context like a decent sub should */
2079 POPBLOCK(cx, PL_curpm);
2080 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2083 return pop_return();
2086 AV* padlist = CvPADLIST(cv);
2087 SV** svp = AvARRAY(padlist);
2088 if (CxTYPE(cx) == CXt_EVAL) {
2089 PL_in_eval = cx->blk_eval.old_in_eval;
2090 PL_eval_root = cx->blk_eval.old_eval_root;
2091 cx->cx_type = CXt_SUB;
2092 cx->blk_sub.hasargs = 0;
2094 cx->blk_sub.cv = cv;
2095 cx->blk_sub.olddepth = CvDEPTH(cv);
2097 if (CvDEPTH(cv) < 2)
2098 (void)SvREFCNT_inc(cv);
2099 else { /* save temporaries on recursion? */
2100 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2101 sub_crush_depth(cv);
2102 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2103 AV *newpad = newAV();
2104 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2105 I32 ix = AvFILLp((AV*)svp[1]);
2106 svp = AvARRAY(svp[0]);
2107 for ( ;ix > 0; ix--) {
2108 if (svp[ix] != &PL_sv_undef) {
2109 char *name = SvPVX(svp[ix]);
2110 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2113 /* outer lexical or anon code */
2114 av_store(newpad, ix,
2115 SvREFCNT_inc(oldpad[ix]) );
2117 else { /* our own lexical */
2119 av_store(newpad, ix, sv = (SV*)newAV());
2120 else if (*name == '%')
2121 av_store(newpad, ix, sv = (SV*)newHV());
2123 av_store(newpad, ix, sv = NEWSV(0,0));
2128 av_store(newpad, ix, sv = NEWSV(0,0));
2132 if (cx->blk_sub.hasargs) {
2135 av_store(newpad, 0, (SV*)av);
2136 AvFLAGS(av) = AVf_REIFY;
2138 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2139 AvFILLp(padlist) = CvDEPTH(cv);
2140 svp = AvARRAY(padlist);
2144 if (!cx->blk_sub.hasargs) {
2145 AV* av = (AV*)PL_curpad[0];
2147 items = AvFILLp(av) + 1;
2149 /* Mark is at the end of the stack. */
2151 Copy(AvARRAY(av), SP + 1, items, SV*);
2156 #endif /* USE_THREADS */
2157 SAVESPTR(PL_curpad);
2158 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2160 if (cx->blk_sub.hasargs)
2161 #endif /* USE_THREADS */
2163 AV* av = (AV*)PL_curpad[0];
2167 cx->blk_sub.savearray = GvAV(PL_defgv);
2168 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2169 #endif /* USE_THREADS */
2170 cx->blk_sub.argarray = av;
2173 if (items >= AvMAX(av) + 1) {
2175 if (AvARRAY(av) != ary) {
2176 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2177 SvPVX(av) = (char*)ary;
2179 if (items >= AvMAX(av) + 1) {
2180 AvMAX(av) = items - 1;
2181 Renew(ary,items+1,SV*);
2183 SvPVX(av) = (char*)ary;
2186 Copy(mark,AvARRAY(av),items,SV*);
2187 AvFILLp(av) = items - 1;
2188 /* preserve @_ nature */
2199 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2201 * We do not care about using sv to call CV;
2202 * it's for informational purposes only.
2204 SV *sv = GvSV(PL_DBsub);
2207 if (PERLDB_SUB_NN) {
2208 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2211 gv_efullname3(sv, CvGV(cv), Nullch);
2214 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2215 PUSHMARK( PL_stack_sp );
2216 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2220 RETURNOP(CvSTART(cv));
2224 label = SvPV(sv,n_a);
2225 if (!(do_dump || *label))
2226 DIE(aTHX_ must_have_label);
2229 else if (PL_op->op_flags & OPf_SPECIAL) {
2231 DIE(aTHX_ must_have_label);
2234 label = cPVOP->op_pv;
2236 if (label && *label) {
2241 PL_lastgotoprobe = 0;
2243 for (ix = cxstack_ix; ix >= 0; ix--) {
2245 switch (CxTYPE(cx)) {
2247 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2250 gotoprobe = cx->blk_oldcop->op_sibling;
2256 gotoprobe = cx->blk_oldcop->op_sibling;
2258 gotoprobe = PL_main_root;
2261 if (CvDEPTH(cx->blk_sub.cv)) {
2262 gotoprobe = CvROOT(cx->blk_sub.cv);
2267 DIE(aTHX_ "Can't \"goto\" outside a block");
2270 DIE(aTHX_ "panic: goto");
2271 gotoprobe = PL_main_root;
2274 retop = dofindlabel(gotoprobe, label,
2275 enterops, enterops + GOTO_DEPTH);
2278 PL_lastgotoprobe = gotoprobe;
2281 DIE(aTHX_ "Can't find label %s", label);
2283 /* pop unwanted frames */
2285 if (ix < cxstack_ix) {
2292 oldsave = PL_scopestack[PL_scopestack_ix];
2293 LEAVE_SCOPE(oldsave);
2296 /* push wanted frames */
2298 if (*enterops && enterops[1]) {
2300 for (ix = 1; enterops[ix]; ix++) {
2301 PL_op = enterops[ix];
2302 /* Eventually we may want to stack the needed arguments
2303 * for each op. For now, we punt on the hard ones. */
2304 if (PL_op->op_type == OP_ENTERITER)
2305 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2307 (CALLOP->op_ppaddr)(aTHX);
2315 if (!retop) retop = PL_main_start;
2317 PL_restartop = retop;
2318 PL_do_undump = TRUE;
2322 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2323 PL_do_undump = FALSE;
2339 if (anum == 1 && VMSISH_EXIT)
2344 PUSHs(&PL_sv_undef);
2352 NV value = SvNVx(GvSV(cCOP->cop_gv));
2353 register I32 match = I_32(value);
2356 if (((NV)match) > value)
2357 --match; /* was fractional--truncate other way */
2359 match -= cCOP->uop.scop.scop_offset;
2362 else if (match > cCOP->uop.scop.scop_max)
2363 match = cCOP->uop.scop.scop_max;
2364 PL_op = cCOP->uop.scop.scop_next[match];
2374 PL_op = PL_op->op_next; /* can't assume anything */
2377 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2378 match -= cCOP->uop.scop.scop_offset;
2381 else if (match > cCOP->uop.scop.scop_max)
2382 match = cCOP->uop.scop.scop_max;
2383 PL_op = cCOP->uop.scop.scop_next[match];
2392 S_save_lines(pTHX_ AV *array, SV *sv)
2394 register char *s = SvPVX(sv);
2395 register char *send = SvPVX(sv) + SvCUR(sv);
2397 register I32 line = 1;
2399 while (s && s < send) {
2400 SV *tmpstr = NEWSV(85,0);
2402 sv_upgrade(tmpstr, SVt_PVMG);
2403 t = strchr(s, '\n');
2409 sv_setpvn(tmpstr, s, t - s);
2410 av_store(array, line++, tmpstr);
2416 S_docatch_body(pTHX_ va_list args)
2423 S_docatch(pTHX_ OP *o)
2430 assert(CATCH_GET == TRUE);
2434 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body));
2440 PL_op = PL_restartop;
2455 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2456 /* sv Text to convert to OP tree. */
2457 /* startop op_free() this to undo. */
2458 /* code Short string id of the caller. */
2460 dSP; /* Make POPBLOCK work. */
2463 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2466 OP *oop = PL_op, *rop;
2467 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2473 /* switch to eval mode */
2475 if (PL_curcop == &PL_compiling) {
2476 SAVESPTR(PL_compiling.cop_stash);
2477 PL_compiling.cop_stash = PL_curstash;
2479 SAVESPTR(PL_compiling.cop_filegv);
2480 SAVEI16(PL_compiling.cop_line);
2481 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2482 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2483 PL_compiling.cop_line = 1;
2484 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2485 deleting the eval's FILEGV from the stash before gv_check() runs
2486 (i.e. before run-time proper). To work around the coredump that
2487 ensues, we always turn GvMULTI_on for any globals that were
2488 introduced within evals. See force_ident(). GSAR 96-10-12 */
2489 safestr = savepv(tmpbuf);
2490 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2492 #ifdef OP_IN_REGISTER
2500 PL_op->op_type = OP_ENTEREVAL;
2501 PL_op->op_flags = 0; /* Avoid uninit warning. */
2502 PUSHBLOCK(cx, CXt_EVAL, SP);
2503 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2504 rop = doeval(G_SCALAR, startop);
2505 POPBLOCK(cx,PL_curpm);
2508 (*startop)->op_type = OP_NULL;
2509 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2511 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2513 if (PL_curcop == &PL_compiling)
2514 PL_compiling.op_private = PL_hints;
2515 #ifdef OP_IN_REGISTER
2521 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2523 S_doeval(pTHX_ int gimme, OP** startop)
2532 PL_in_eval = EVAL_INEVAL;
2536 /* set up a scratch pad */
2539 SAVESPTR(PL_curpad);
2540 SAVESPTR(PL_comppad);
2541 SAVESPTR(PL_comppad_name);
2542 SAVEI32(PL_comppad_name_fill);
2543 SAVEI32(PL_min_intro_pending);
2544 SAVEI32(PL_max_intro_pending);
2547 for (i = cxstack_ix - 1; i >= 0; i--) {
2548 PERL_CONTEXT *cx = &cxstack[i];
2549 if (CxTYPE(cx) == CXt_EVAL)
2551 else if (CxTYPE(cx) == CXt_SUB) {
2552 caller = cx->blk_sub.cv;
2557 SAVESPTR(PL_compcv);
2558 PL_compcv = (CV*)NEWSV(1104,0);
2559 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2560 CvEVAL_on(PL_compcv);
2562 CvOWNER(PL_compcv) = 0;
2563 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2564 MUTEX_INIT(CvMUTEXP(PL_compcv));
2565 #endif /* USE_THREADS */
2567 PL_comppad = newAV();
2568 av_push(PL_comppad, Nullsv);
2569 PL_curpad = AvARRAY(PL_comppad);
2570 PL_comppad_name = newAV();
2571 PL_comppad_name_fill = 0;
2572 PL_min_intro_pending = 0;
2575 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2576 PL_curpad[0] = (SV*)newAV();
2577 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2578 #endif /* USE_THREADS */
2580 comppadlist = newAV();
2581 AvREAL_off(comppadlist);
2582 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2583 av_store(comppadlist, 1, (SV*)PL_comppad);
2584 CvPADLIST(PL_compcv) = comppadlist;
2586 if (!saveop || saveop->op_type != OP_REQUIRE)
2587 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2589 SAVEFREESV(PL_compcv);
2591 /* make sure we compile in the right package */
2593 newstash = PL_curcop->cop_stash;
2594 if (PL_curstash != newstash) {
2595 SAVESPTR(PL_curstash);
2596 PL_curstash = newstash;
2598 SAVESPTR(PL_beginav);
2599 PL_beginav = newAV();
2600 SAVEFREESV(PL_beginav);
2602 /* try to compile it */
2604 PL_eval_root = Nullop;
2606 PL_curcop = &PL_compiling;
2607 PL_curcop->cop_arybase = 0;
2608 SvREFCNT_dec(PL_rs);
2609 PL_rs = newSVpvn("\n", 1);
2610 if (saveop && saveop->op_flags & OPf_SPECIAL)
2611 PL_in_eval |= EVAL_KEEPERR;
2614 if (yyparse() || PL_error_count || !PL_eval_root) {
2618 I32 optype = 0; /* Might be reset by POPEVAL. */
2623 op_free(PL_eval_root);
2624 PL_eval_root = Nullop;
2626 SP = PL_stack_base + POPMARK; /* pop original mark */
2628 POPBLOCK(cx,PL_curpm);
2634 if (optype == OP_REQUIRE) {
2635 char* msg = SvPVx(ERRSV, n_a);
2636 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
2637 } else if (startop) {
2638 char* msg = SvPVx(ERRSV, n_a);
2640 POPBLOCK(cx,PL_curpm);
2642 Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2644 SvREFCNT_dec(PL_rs);
2645 PL_rs = SvREFCNT_inc(PL_nrs);
2647 MUTEX_LOCK(&PL_eval_mutex);
2649 COND_SIGNAL(&PL_eval_cond);
2650 MUTEX_UNLOCK(&PL_eval_mutex);
2651 #endif /* USE_THREADS */
2654 SvREFCNT_dec(PL_rs);
2655 PL_rs = SvREFCNT_inc(PL_nrs);
2656 PL_compiling.cop_line = 0;
2658 *startop = PL_eval_root;
2659 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2660 CvOUTSIDE(PL_compcv) = Nullcv;
2662 SAVEFREEOP(PL_eval_root);
2664 scalarvoid(PL_eval_root);
2665 else if (gimme & G_ARRAY)
2668 scalar(PL_eval_root);
2670 DEBUG_x(dump_eval());
2672 /* Register with debugger: */
2673 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2674 CV *cv = get_cv("DB::postponed", FALSE);
2678 XPUSHs((SV*)PL_compiling.cop_filegv);
2680 call_sv((SV*)cv, G_DISCARD);
2684 /* compiled okay, so do it */
2686 CvDEPTH(PL_compcv) = 1;
2687 SP = PL_stack_base + POPMARK; /* pop original mark */
2688 PL_op = saveop; /* The caller may need it. */
2690 MUTEX_LOCK(&PL_eval_mutex);
2692 COND_SIGNAL(&PL_eval_cond);
2693 MUTEX_UNLOCK(&PL_eval_mutex);
2694 #endif /* USE_THREADS */
2696 RETURNOP(PL_eval_start);
2700 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2702 STRLEN namelen = strlen(name);
2705 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2706 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2707 char *pmc = SvPV_nolen(pmcsv);
2710 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2711 fp = PerlIO_open(name, mode);
2714 if (PerlLIO_stat(name, &pmstat) < 0 ||
2715 pmstat.st_mtime < pmcstat.st_mtime)
2717 fp = PerlIO_open(pmc, mode);
2720 fp = PerlIO_open(name, mode);
2723 SvREFCNT_dec(pmcsv);
2726 fp = PerlIO_open(name, mode);
2734 register PERL_CONTEXT *cx;
2739 SV *namesv = Nullsv;
2741 I32 gimme = G_SCALAR;
2742 PerlIO *tryrsfp = 0;
2744 int filter_has_file = 0;
2745 GV *filter_child_proc = 0;
2746 SV *filter_state = 0;
2750 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2751 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2752 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2753 SvPV(sv,n_a),PL_patchlevel);
2756 name = SvPV(sv, len);
2757 if (!(name && len > 0 && *name))
2758 DIE(aTHX_ "Null filename used");
2759 TAINT_PROPER("require");
2760 if (PL_op->op_type == OP_REQUIRE &&
2761 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2762 *svp != &PL_sv_undef)
2765 /* prepare to compile file */
2770 (name[1] == '.' && name[2] == '/')))
2772 || (name[0] && name[1] == ':')
2775 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2778 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2779 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2784 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2787 AV *ar = GvAVn(PL_incgv);
2791 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2794 namesv = NEWSV(806, 0);
2795 for (i = 0; i <= AvFILL(ar); i++) {
2796 SV *dirsv = *av_fetch(ar, i, TRUE);
2802 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2803 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2806 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%lx/%s",
2807 SvANY(loader), name);
2808 tryname = SvPVX(namesv);
2819 count = call_sv(loader, G_ARRAY);
2829 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2833 if (SvTYPE(arg) == SVt_PVGV) {
2834 IO *io = GvIO((GV *)arg);
2839 tryrsfp = IoIFP(io);
2840 if (IoTYPE(io) == '|') {
2841 /* reading from a child process doesn't
2842 nest -- when returning from reading
2843 the inner module, the outer one is
2844 unreadable (closed?) I've tried to
2845 save the gv to manage the lifespan of
2846 the pipe, but this didn't help. XXX */
2847 filter_child_proc = (GV *)arg;
2848 (void)SvREFCNT_inc(filter_child_proc);
2851 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2852 PerlIO_close(IoOFP(io));
2864 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2866 (void)SvREFCNT_inc(filter_sub);
2869 filter_state = SP[i];
2870 (void)SvREFCNT_inc(filter_state);
2874 tryrsfp = PerlIO_open("/dev/null",
2888 filter_has_file = 0;
2889 if (filter_child_proc) {
2890 SvREFCNT_dec(filter_child_proc);
2891 filter_child_proc = 0;
2894 SvREFCNT_dec(filter_state);
2898 SvREFCNT_dec(filter_sub);
2903 char *dir = SvPVx(dirsv, n_a);
2906 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2908 sv_setpv(namesv, unixdir);
2909 sv_catpv(namesv, unixname);
2911 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2913 TAINT_PROPER("require");
2914 tryname = SvPVX(namesv);
2915 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2917 if (tryname[0] == '.' && tryname[1] == '/')
2925 SAVESPTR(PL_compiling.cop_filegv);
2926 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2927 SvREFCNT_dec(namesv);
2929 if (PL_op->op_type == OP_REQUIRE) {
2930 char *msgstr = name;
2931 if (namesv) { /* did we lookup @INC? */
2932 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2933 SV *dirmsgsv = NEWSV(0, 0);
2934 AV *ar = GvAVn(PL_incgv);
2936 sv_catpvn(msg, " in @INC", 8);
2937 if (instr(SvPVX(msg), ".h "))
2938 sv_catpv(msg, " (change .h to .ph maybe?)");
2939 if (instr(SvPVX(msg), ".ph "))
2940 sv_catpv(msg, " (did you run h2ph?)");
2941 sv_catpv(msg, " (@INC contains:");
2942 for (i = 0; i <= AvFILL(ar); i++) {
2943 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2944 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
2945 sv_catsv(msg, dirmsgsv);
2947 sv_catpvn(msg, ")", 1);
2948 SvREFCNT_dec(dirmsgsv);
2949 msgstr = SvPV_nolen(msg);
2951 DIE(aTHX_ "Can't locate %s", msgstr);
2957 SETERRNO(0, SS$_NORMAL);
2959 /* Assume success here to prevent recursive requirement. */
2960 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2961 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2965 lex_start(sv_2mortal(newSVpvn("",0)));
2966 SAVEGENERICSV(PL_rsfp_filters);
2967 PL_rsfp_filters = Nullav;
2970 name = savepv(name);
2974 SAVEPPTR(PL_compiling.cop_warnings);
2975 if (PL_dowarn & G_WARN_ALL_ON)
2976 PL_compiling.cop_warnings = WARN_ALL ;
2977 else if (PL_dowarn & G_WARN_ALL_OFF)
2978 PL_compiling.cop_warnings = WARN_NONE ;
2980 PL_compiling.cop_warnings = WARN_STD ;
2982 if (filter_sub || filter_child_proc) {
2983 SV *datasv = filter_add(run_user_filter, Nullsv);
2984 IoLINES(datasv) = filter_has_file;
2985 IoFMT_GV(datasv) = (GV *)filter_child_proc;
2986 IoTOP_GV(datasv) = (GV *)filter_state;
2987 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
2990 /* switch to eval mode */
2991 push_return(PL_op->op_next);
2992 PUSHBLOCK(cx, CXt_EVAL, SP);
2993 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2995 SAVEI16(PL_compiling.cop_line);
2996 PL_compiling.cop_line = 0;
3000 MUTEX_LOCK(&PL_eval_mutex);
3001 if (PL_eval_owner && PL_eval_owner != thr)
3002 while (PL_eval_owner)
3003 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3004 PL_eval_owner = thr;
3005 MUTEX_UNLOCK(&PL_eval_mutex);
3006 #endif /* USE_THREADS */
3007 return DOCATCH(doeval(G_SCALAR, NULL));
3012 return pp_require();
3018 register PERL_CONTEXT *cx;
3020 I32 gimme = GIMME_V, was = PL_sub_generation;
3021 char tmpbuf[TYPE_DIGITS(long) + 12];
3026 if (!SvPV(sv,len) || !len)
3028 TAINT_PROPER("eval");
3034 /* switch to eval mode */
3036 SAVESPTR(PL_compiling.cop_filegv);
3037 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3038 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3039 PL_compiling.cop_line = 1;
3040 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3041 deleting the eval's FILEGV from the stash before gv_check() runs
3042 (i.e. before run-time proper). To work around the coredump that
3043 ensues, we always turn GvMULTI_on for any globals that were
3044 introduced within evals. See force_ident(). GSAR 96-10-12 */
3045 safestr = savepv(tmpbuf);
3046 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3048 PL_hints = PL_op->op_targ;
3049 SAVEPPTR(PL_compiling.cop_warnings);
3050 if (!specialWARN(PL_compiling.cop_warnings)) {
3051 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3052 SAVEFREESV(PL_compiling.cop_warnings) ;
3055 push_return(PL_op->op_next);
3056 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3057 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3059 /* prepare to compile string */
3061 if (PERLDB_LINE && PL_curstash != PL_debstash)
3062 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3065 MUTEX_LOCK(&PL_eval_mutex);
3066 if (PL_eval_owner && PL_eval_owner != thr)
3067 while (PL_eval_owner)
3068 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3069 PL_eval_owner = thr;
3070 MUTEX_UNLOCK(&PL_eval_mutex);
3071 #endif /* USE_THREADS */
3072 ret = doeval(gimme, NULL);
3073 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3074 && ret != PL_op->op_next) { /* Successive compilation. */
3075 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3077 return DOCATCH(ret);
3087 register PERL_CONTEXT *cx;
3089 U8 save_flags = PL_op -> op_flags;
3094 retop = pop_return();
3097 if (gimme == G_VOID)
3099 else if (gimme == G_SCALAR) {
3102 if (SvFLAGS(TOPs) & SVs_TEMP)
3105 *MARK = sv_mortalcopy(TOPs);
3109 *MARK = &PL_sv_undef;
3113 /* in case LEAVE wipes old return values */
3114 for (mark = newsp + 1; mark <= SP; mark++) {
3115 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3116 *mark = sv_mortalcopy(*mark);
3117 TAINT_NOT; /* Each item is independent */
3121 PL_curpm = newpm; /* Don't pop $1 et al till now */
3123 if (AvFILLp(PL_comppad_name) >= 0)
3127 assert(CvDEPTH(PL_compcv) == 1);
3129 CvDEPTH(PL_compcv) = 0;
3132 if (optype == OP_REQUIRE &&
3133 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3135 /* Unassume the success we assumed earlier. */
3136 char *name = cx->blk_eval.old_name;
3137 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3138 retop = Perl_die(aTHX_ "%s did not return a true value", name);
3139 /* die_where() did LEAVE, or we won't be here */
3143 if (!(save_flags & OPf_SPECIAL))
3153 register PERL_CONTEXT *cx;
3154 I32 gimme = GIMME_V;
3159 push_return(cLOGOP->op_other->op_next);
3160 PUSHBLOCK(cx, CXt_EVAL, SP);
3162 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3164 PL_in_eval = EVAL_INEVAL;
3167 return DOCATCH(PL_op->op_next);
3177 register PERL_CONTEXT *cx;
3185 if (gimme == G_VOID)
3187 else if (gimme == G_SCALAR) {
3190 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3193 *MARK = sv_mortalcopy(TOPs);
3197 *MARK = &PL_sv_undef;
3202 /* in case LEAVE wipes old return values */
3203 for (mark = newsp + 1; mark <= SP; mark++) {
3204 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3205 *mark = sv_mortalcopy(*mark);
3206 TAINT_NOT; /* Each item is independent */
3210 PL_curpm = newpm; /* Don't pop $1 et al till now */
3218 S_doparseform(pTHX_ SV *sv)
3221 register char *s = SvPV_force(sv, len);
3222 register char *send = s + len;
3223 register char *base;
3224 register I32 skipspaces = 0;
3227 bool postspace = FALSE;
3235 Perl_croak(aTHX_ "Null picture in formline");
3237 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3242 *fpc++ = FF_LINEMARK;
3243 noblank = repeat = FALSE;
3261 case ' ': case '\t':
3272 *fpc++ = FF_LITERAL;
3280 *fpc++ = skipspaces;
3284 *fpc++ = FF_NEWLINE;
3288 arg = fpc - linepc + 1;
3295 *fpc++ = FF_LINEMARK;
3296 noblank = repeat = FALSE;
3305 ischop = s[-1] == '^';
3311 arg = (s - base) - 1;
3313 *fpc++ = FF_LITERAL;
3322 *fpc++ = FF_LINEGLOB;
3324 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3325 arg = ischop ? 512 : 0;
3335 arg |= 256 + (s - f);
3337 *fpc++ = s - base; /* fieldsize for FETCH */
3338 *fpc++ = FF_DECIMAL;
3343 bool ismore = FALSE;
3346 while (*++s == '>') ;
3347 prespace = FF_SPACE;
3349 else if (*s == '|') {
3350 while (*++s == '|') ;
3351 prespace = FF_HALFSPACE;
3356 while (*++s == '<') ;
3359 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3363 *fpc++ = s - base; /* fieldsize for FETCH */
3365 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3383 { /* need to jump to the next word */
3385 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3386 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3387 s = SvPVX(sv) + SvCUR(sv) + z;
3389 Copy(fops, s, arg, U16);
3391 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3396 * The rest of this file was derived from source code contributed
3399 * NOTE: this code was derived from Tom Horsley's qsort replacement
3400 * and should not be confused with the original code.
3403 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3405 Permission granted to distribute under the same terms as perl which are
3408 This program is free software; you can redistribute it and/or modify
3409 it under the terms of either:
3411 a) the GNU General Public License as published by the Free
3412 Software Foundation; either version 1, or (at your option) any
3415 b) the "Artistic License" which comes with this Kit.
3417 Details on the perl license can be found in the perl source code which
3418 may be located via the www.perl.com web page.
3420 This is the most wonderfulest possible qsort I can come up with (and
3421 still be mostly portable) My (limited) tests indicate it consistently
3422 does about 20% fewer calls to compare than does the qsort in the Visual
3423 C++ library, other vendors may vary.
3425 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3426 others I invented myself (or more likely re-invented since they seemed
3427 pretty obvious once I watched the algorithm operate for a while).
3429 Most of this code was written while watching the Marlins sweep the Giants
3430 in the 1997 National League Playoffs - no Braves fans allowed to use this
3431 code (just kidding :-).
3433 I realize that if I wanted to be true to the perl tradition, the only
3434 comment in this file would be something like:
3436 ...they shuffled back towards the rear of the line. 'No, not at the
3437 rear!' the slave-driver shouted. 'Three files up. And stay there...
3439 However, I really needed to violate that tradition just so I could keep
3440 track of what happens myself, not to mention some poor fool trying to
3441 understand this years from now :-).
3444 /* ********************************************************** Configuration */
3446 #ifndef QSORT_ORDER_GUESS
3447 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3450 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3451 future processing - a good max upper bound is log base 2 of memory size
3452 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3453 safely be smaller than that since the program is taking up some space and
3454 most operating systems only let you grab some subset of contiguous
3455 memory (not to mention that you are normally sorting data larger than
3456 1 byte element size :-).
3458 #ifndef QSORT_MAX_STACK
3459 #define QSORT_MAX_STACK 32
3462 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3463 Anything bigger and we use qsort. If you make this too small, the qsort
3464 will probably break (or become less efficient), because it doesn't expect
3465 the middle element of a partition to be the same as the right or left -
3466 you have been warned).
3468 #ifndef QSORT_BREAK_EVEN
3469 #define QSORT_BREAK_EVEN 6
3472 /* ************************************************************* Data Types */
3474 /* hold left and right index values of a partition waiting to be sorted (the
3475 partition includes both left and right - right is NOT one past the end or
3476 anything like that).
3478 struct partition_stack_entry {
3481 #ifdef QSORT_ORDER_GUESS
3482 int qsort_break_even;
3486 /* ******************************************************* Shorthand Macros */
3488 /* Note that these macros will be used from inside the qsort function where
3489 we happen to know that the variable 'elt_size' contains the size of an
3490 array element and the variable 'temp' points to enough space to hold a
3491 temp element and the variable 'array' points to the array being sorted
3492 and 'compare' is the pointer to the compare routine.
3494 Also note that there are very many highly architecture specific ways
3495 these might be sped up, but this is simply the most generally portable
3496 code I could think of.
3499 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3501 #define qsort_cmp(elt1, elt2) \
3502 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3504 #ifdef QSORT_ORDER_GUESS
3505 #define QSORT_NOTICE_SWAP swapped++;
3507 #define QSORT_NOTICE_SWAP
3510 /* swaps contents of array elements elt1, elt2.
3512 #define qsort_swap(elt1, elt2) \
3515 temp = array[elt1]; \
3516 array[elt1] = array[elt2]; \
3517 array[elt2] = temp; \
3520 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3521 elt3 and elt3 gets elt1.
3523 #define qsort_rotate(elt1, elt2, elt3) \
3526 temp = array[elt1]; \
3527 array[elt1] = array[elt2]; \
3528 array[elt2] = array[elt3]; \
3529 array[elt3] = temp; \
3532 /* ************************************************************ Debug stuff */
3539 return; /* good place to set a breakpoint */
3542 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3545 doqsort_all_asserts(
3549 int (*compare)(const void * elt1, const void * elt2),
3550 int pc_left, int pc_right, int u_left, int u_right)
3554 qsort_assert(pc_left <= pc_right);
3555 qsort_assert(u_right < pc_left);
3556 qsort_assert(pc_right < u_left);
3557 for (i = u_right + 1; i < pc_left; ++i) {
3558 qsort_assert(qsort_cmp(i, pc_left) < 0);
3560 for (i = pc_left; i < pc_right; ++i) {
3561 qsort_assert(qsort_cmp(i, pc_right) == 0);
3563 for (i = pc_right + 1; i < u_left; ++i) {
3564 qsort_assert(qsort_cmp(pc_right, i) < 0);
3568 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3569 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3570 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3574 #define qsort_assert(t) ((void)0)
3576 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3580 /* ****************************************************************** qsort */
3583 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3587 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3588 int next_stack_entry = 0;
3592 #ifdef QSORT_ORDER_GUESS
3593 int qsort_break_even;
3597 /* Make sure we actually have work to do.
3599 if (num_elts <= 1) {
3603 /* Setup the initial partition definition and fall into the sorting loop
3606 part_right = (int)(num_elts - 1);
3607 #ifdef QSORT_ORDER_GUESS
3608 qsort_break_even = QSORT_BREAK_EVEN;
3610 #define qsort_break_even QSORT_BREAK_EVEN
3613 if ((part_right - part_left) >= qsort_break_even) {
3614 /* OK, this is gonna get hairy, so lets try to document all the
3615 concepts and abbreviations and variables and what they keep
3618 pc: pivot chunk - the set of array elements we accumulate in the
3619 middle of the partition, all equal in value to the original
3620 pivot element selected. The pc is defined by:
3622 pc_left - the leftmost array index of the pc
3623 pc_right - the rightmost array index of the pc
3625 we start with pc_left == pc_right and only one element
3626 in the pivot chunk (but it can grow during the scan).
3628 u: uncompared elements - the set of elements in the partition
3629 we have not yet compared to the pivot value. There are two
3630 uncompared sets during the scan - one to the left of the pc
3631 and one to the right.
3633 u_right - the rightmost index of the left side's uncompared set
3634 u_left - the leftmost index of the right side's uncompared set
3636 The leftmost index of the left sides's uncompared set
3637 doesn't need its own variable because it is always defined
3638 by the leftmost edge of the whole partition (part_left). The
3639 same goes for the rightmost edge of the right partition
3642 We know there are no uncompared elements on the left once we
3643 get u_right < part_left and no uncompared elements on the
3644 right once u_left > part_right. When both these conditions
3645 are met, we have completed the scan of the partition.
3647 Any elements which are between the pivot chunk and the
3648 uncompared elements should be less than the pivot value on
3649 the left side and greater than the pivot value on the right
3650 side (in fact, the goal of the whole algorithm is to arrange
3651 for that to be true and make the groups of less-than and
3652 greater-then elements into new partitions to sort again).
3654 As you marvel at the complexity of the code and wonder why it
3655 has to be so confusing. Consider some of the things this level
3656 of confusion brings:
3658 Once I do a compare, I squeeze every ounce of juice out of it. I
3659 never do compare calls I don't have to do, and I certainly never
3662 I also never swap any elements unless I can prove there is a
3663 good reason. Many sort algorithms will swap a known value with
3664 an uncompared value just to get things in the right place (or
3665 avoid complexity :-), but that uncompared value, once it gets
3666 compared, may then have to be swapped again. A lot of the
3667 complexity of this code is due to the fact that it never swaps
3668 anything except compared values, and it only swaps them when the
3669 compare shows they are out of position.
3671 int pc_left, pc_right;
3672 int u_right, u_left;
3676 pc_left = ((part_left + part_right) / 2);
3678 u_right = pc_left - 1;
3679 u_left = pc_right + 1;
3681 /* Qsort works best when the pivot value is also the median value
3682 in the partition (unfortunately you can't find the median value
3683 without first sorting :-), so to give the algorithm a helping
3684 hand, we pick 3 elements and sort them and use the median value
3685 of that tiny set as the pivot value.
3687 Some versions of qsort like to use the left middle and right as
3688 the 3 elements to sort so they can insure the ends of the
3689 partition will contain values which will stop the scan in the
3690 compare loop, but when you have to call an arbitrarily complex
3691 routine to do a compare, its really better to just keep track of
3692 array index values to know when you hit the edge of the
3693 partition and avoid the extra compare. An even better reason to
3694 avoid using a compare call is the fact that you can drop off the
3695 edge of the array if someone foolishly provides you with an
3696 unstable compare function that doesn't always provide consistent
3699 So, since it is simpler for us to compare the three adjacent
3700 elements in the middle of the partition, those are the ones we
3701 pick here (conveniently pointed at by u_right, pc_left, and
3702 u_left). The values of the left, center, and right elements
3703 are refered to as l c and r in the following comments.
3706 #ifdef QSORT_ORDER_GUESS
3709 s = qsort_cmp(u_right, pc_left);
3712 s = qsort_cmp(pc_left, u_left);
3713 /* if l < c, c < r - already in order - nothing to do */
3715 /* l < c, c == r - already in order, pc grows */
3717 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3719 /* l < c, c > r - need to know more */
3720 s = qsort_cmp(u_right, u_left);
3722 /* l < c, c > r, l < r - swap c & r to get ordered */
3723 qsort_swap(pc_left, u_left);
3724 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3725 } else if (s == 0) {
3726 /* l < c, c > r, l == r - swap c&r, grow pc */
3727 qsort_swap(pc_left, u_left);
3729 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3731 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3732 qsort_rotate(pc_left, u_right, u_left);
3733 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3736 } else if (s == 0) {
3738 s = qsort_cmp(pc_left, u_left);
3740 /* l == c, c < r - already in order, grow pc */
3742 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3743 } else if (s == 0) {
3744 /* l == c, c == r - already in order, grow pc both ways */
3747 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3749 /* l == c, c > r - swap l & r, grow pc */
3750 qsort_swap(u_right, u_left);
3752 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3756 s = qsort_cmp(pc_left, u_left);
3758 /* l > c, c < r - need to know more */
3759 s = qsort_cmp(u_right, u_left);
3761 /* l > c, c < r, l < r - swap l & c to get ordered */
3762 qsort_swap(u_right, pc_left);
3763 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3764 } else if (s == 0) {
3765 /* l > c, c < r, l == r - swap l & c, grow pc */
3766 qsort_swap(u_right, pc_left);
3768 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3770 /* l > c, c < r, l > r - rotate lcr into crl to order */
3771 qsort_rotate(u_right, pc_left, u_left);
3772 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3774 } else if (s == 0) {
3775 /* l > c, c == r - swap ends, grow pc */
3776 qsort_swap(u_right, u_left);
3778 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3780 /* l > c, c > r - swap ends to get in order */
3781 qsort_swap(u_right, u_left);
3782 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3785 /* We now know the 3 middle elements have been compared and
3786 arranged in the desired order, so we can shrink the uncompared
3791 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3793 /* The above massive nested if was the simple part :-). We now have
3794 the middle 3 elements ordered and we need to scan through the
3795 uncompared sets on either side, swapping elements that are on
3796 the wrong side or simply shuffling equal elements around to get
3797 all equal elements into the pivot chunk.
3801 int still_work_on_left;
3802 int still_work_on_right;
3804 /* Scan the uncompared values on the left. If I find a value
3805 equal to the pivot value, move it over so it is adjacent to
3806 the pivot chunk and expand the pivot chunk. If I find a value
3807 less than the pivot value, then just leave it - its already
3808 on the correct side of the partition. If I find a greater
3809 value, then stop the scan.
3811 while (still_work_on_left = (u_right >= part_left)) {
3812 s = qsort_cmp(u_right, pc_left);
3815 } else if (s == 0) {
3817 if (pc_left != u_right) {
3818 qsort_swap(u_right, pc_left);
3824 qsort_assert(u_right < pc_left);
3825 qsort_assert(pc_left <= pc_right);
3826 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3827 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3830 /* Do a mirror image scan of uncompared values on the right
3832 while (still_work_on_right = (u_left <= part_right)) {
3833 s = qsort_cmp(pc_right, u_left);
3836 } else if (s == 0) {
3838 if (pc_right != u_left) {
3839 qsort_swap(pc_right, u_left);
3845 qsort_assert(u_left > pc_right);
3846 qsort_assert(pc_left <= pc_right);
3847 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3848 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3851 if (still_work_on_left) {
3852 /* I know I have a value on the left side which needs to be
3853 on the right side, but I need to know more to decide
3854 exactly the best thing to do with it.
3856 if (still_work_on_right) {
3857 /* I know I have values on both side which are out of
3858 position. This is a big win because I kill two birds
3859 with one swap (so to speak). I can advance the
3860 uncompared pointers on both sides after swapping both
3861 of them into the right place.
3863 qsort_swap(u_right, u_left);
3866 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3868 /* I have an out of position value on the left, but the
3869 right is fully scanned, so I "slide" the pivot chunk
3870 and any less-than values left one to make room for the
3871 greater value over on the right. If the out of position
3872 value is immediately adjacent to the pivot chunk (there
3873 are no less-than values), I can do that with a swap,
3874 otherwise, I have to rotate one of the less than values
3875 into the former position of the out of position value
3876 and the right end of the pivot chunk into the left end
3880 if (pc_left == u_right) {
3881 qsort_swap(u_right, pc_right);
3882 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3884 qsort_rotate(u_right, pc_left, pc_right);
3885 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3890 } else if (still_work_on_right) {
3891 /* Mirror image of complex case above: I have an out of
3892 position value on the right, but the left is fully
3893 scanned, so I need to shuffle things around to make room
3894 for the right value on the left.
3897 if (pc_right == u_left) {
3898 qsort_swap(u_left, pc_left);
3899 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3901 qsort_rotate(pc_right, pc_left, u_left);
3902 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3907 /* No more scanning required on either side of partition,
3908 break out of loop and figure out next set of partitions
3914 /* The elements in the pivot chunk are now in the right place. They
3915 will never move or be compared again. All I have to do is decide
3916 what to do with the stuff to the left and right of the pivot
3919 Notes on the QSORT_ORDER_GUESS ifdef code:
3921 1. If I just built these partitions without swapping any (or
3922 very many) elements, there is a chance that the elements are
3923 already ordered properly (being properly ordered will
3924 certainly result in no swapping, but the converse can't be
3927 2. A (properly written) insertion sort will run faster on
3928 already ordered data than qsort will.
3930 3. Perhaps there is some way to make a good guess about
3931 switching to an insertion sort earlier than partition size 6
3932 (for instance - we could save the partition size on the stack
3933 and increase the size each time we find we didn't swap, thus
3934 switching to insertion sort earlier for partitions with a
3935 history of not swapping).
3937 4. Naturally, if I just switch right away, it will make
3938 artificial benchmarks with pure ascending (or descending)
3939 data look really good, but is that a good reason in general?
3943 #ifdef QSORT_ORDER_GUESS
3945 #if QSORT_ORDER_GUESS == 1
3946 qsort_break_even = (part_right - part_left) + 1;
3948 #if QSORT_ORDER_GUESS == 2
3949 qsort_break_even *= 2;
3951 #if QSORT_ORDER_GUESS == 3
3952 int prev_break = qsort_break_even;
3953 qsort_break_even *= qsort_break_even;
3954 if (qsort_break_even < prev_break) {
3955 qsort_break_even = (part_right - part_left) + 1;
3959 qsort_break_even = QSORT_BREAK_EVEN;
3963 if (part_left < pc_left) {
3964 /* There are elements on the left which need more processing.
3965 Check the right as well before deciding what to do.
3967 if (pc_right < part_right) {
3968 /* We have two partitions to be sorted. Stack the biggest one
3969 and process the smallest one on the next iteration. This
3970 minimizes the stack height by insuring that any additional
3971 stack entries must come from the smallest partition which
3972 (because it is smallest) will have the fewest
3973 opportunities to generate additional stack entries.
3975 if ((part_right - pc_right) > (pc_left - part_left)) {
3976 /* stack the right partition, process the left */
3977 partition_stack[next_stack_entry].left = pc_right + 1;
3978 partition_stack[next_stack_entry].right = part_right;
3979 #ifdef QSORT_ORDER_GUESS
3980 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3982 part_right = pc_left - 1;
3984 /* stack the left partition, process the right */
3985 partition_stack[next_stack_entry].left = part_left;
3986 partition_stack[next_stack_entry].right = pc_left - 1;
3987 #ifdef QSORT_ORDER_GUESS
3988 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3990 part_left = pc_right + 1;
3992 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3995 /* The elements on the left are the only remaining elements
3996 that need sorting, arrange for them to be processed as the
3999 part_right = pc_left - 1;
4001 } else if (pc_right < part_right) {
4002 /* There is only one chunk on the right to be sorted, make it
4003 the new partition and loop back around.
4005 part_left = pc_right + 1;
4007 /* This whole partition wound up in the pivot chunk, so
4008 we need to get a new partition off the stack.
4010 if (next_stack_entry == 0) {
4011 /* the stack is empty - we are done */
4015 part_left = partition_stack[next_stack_entry].left;
4016 part_right = partition_stack[next_stack_entry].right;
4017 #ifdef QSORT_ORDER_GUESS
4018 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4022 /* This partition is too small to fool with qsort complexity, just
4023 do an ordinary insertion sort to minimize overhead.
4026 /* Assume 1st element is in right place already, and start checking
4027 at 2nd element to see where it should be inserted.
4029 for (i = part_left + 1; i <= part_right; ++i) {
4031 /* Scan (backwards - just in case 'i' is already in right place)
4032 through the elements already sorted to see if the ith element
4033 belongs ahead of one of them.
4035 for (j = i - 1; j >= part_left; --j) {
4036 if (qsort_cmp(i, j) >= 0) {
4037 /* i belongs right after j
4044 /* Looks like we really need to move some things
4048 for (k = i - 1; k >= j; --k)
4049 array[k + 1] = array[k];
4054 /* That partition is now sorted, grab the next one, or get out
4055 of the loop if there aren't any more.
4058 if (next_stack_entry == 0) {
4059 /* the stack is empty - we are done */
4063 part_left = partition_stack[next_stack_entry].left;
4064 part_right = partition_stack[next_stack_entry].right;
4065 #ifdef QSORT_ORDER_GUESS
4066 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4071 /* Believe it or not, the array is sorted at this point! */
4084 sortcv(pTHXo_ SV *a, SV *b)
4087 I32 oldsaveix = PL_savestack_ix;
4088 I32 oldscopeix = PL_scopestack_ix;
4090 GvSV(PL_firstgv) = a;
4091 GvSV(PL_secondgv) = b;
4092 PL_stack_sp = PL_stack_base;
4095 if (PL_stack_sp != PL_stack_base + 1)
4096 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4097 if (!SvNIOKp(*PL_stack_sp))
4098 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4099 result = SvIV(*PL_stack_sp);
4100 while (PL_scopestack_ix > oldscopeix) {
4103 leave_scope(oldsaveix);
4109 sv_ncmp(pTHXo_ SV *a, SV *b)
4113 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4117 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4121 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4123 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4125 if (PL_amagic_generation) { \
4126 if (SvAMAGIC(left)||SvAMAGIC(right))\
4127 *svp = amagic_call(left, \
4135 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4138 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4143 I32 i = SvIVX(tmpsv);
4153 return sv_ncmp(aTHXo_ a, b);
4157 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4160 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4165 I32 i = SvIVX(tmpsv);
4175 return sv_i_ncmp(aTHXo_ a, b);
4179 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4182 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4187 I32 i = SvIVX(tmpsv);
4197 return sv_cmp(str1, str2);
4201 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4204 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4209 I32 i = SvIVX(tmpsv);
4219 return sv_cmp_locale(str1, str2);
4223 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4225 SV *datasv = FILTER_DATA(idx);
4226 int filter_has_file = IoLINES(datasv);
4227 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4228 SV *filter_state = (SV *)IoTOP_GV(datasv);
4229 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4232 /* I was having segfault trouble under Linux 2.2.5 after a
4233 parse error occured. (Had to hack around it with a test
4234 for PL_error_count == 0.) Solaris doesn't segfault --
4235 not sure where the trouble is yet. XXX */
4237 if (filter_has_file) {
4238 len = FILTER_READ(idx+1, buf_sv, maxlen);
4241 if (filter_sub && len >= 0) {
4252 PUSHs(sv_2mortal(newSViv(maxlen)));
4254 PUSHs(filter_state);
4257 count = call_sv(filter_sub, G_SCALAR);
4273 IoLINES(datasv) = 0;
4274 if (filter_child_proc) {
4275 SvREFCNT_dec(filter_child_proc);
4276 IoFMT_GV(datasv) = Nullgv;
4279 SvREFCNT_dec(filter_state);
4280 IoTOP_GV(datasv) = Nullgv;
4283 SvREFCNT_dec(filter_sub);
4284 IoBOTTOM_GV(datasv) = Nullgv;
4286 filter_del(run_user_filter);
4295 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4297 return sv_cmp_locale(str1, str2);
4301 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4303 return sv_cmp(str1, str2);
4306 #endif /* PERL_OBJECT */