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))
29 static I32 sortcv(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, 'r');
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
117 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
118 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
119 inside tie/overload accessors. */
123 #ifndef INCOMPLETE_TAINTS
126 pm->op_pmdynflags |= PMdf_TAINTED;
128 pm->op_pmdynflags &= ~PMdf_TAINTED;
132 if (!pm->op_pmregexp->prelen && PL_curpm)
134 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
135 pm->op_pmflags |= PMf_WHITE;
137 /* XXX runtime compiled output needs to move to the pad */
138 if (pm->op_pmflags & PMf_KEEP) {
139 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
140 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
141 /* XXX can't change the optree at runtime either */
142 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++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
233 RX_MATCH_COPIED_off(rx);
237 *p++ = PTR2UV(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 = INT2PTR(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(INT2PTR(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(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
341 PerlIO_printf(Perl_debug_log, "%-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;
787 bool hasargs = FALSE;
790 if (gimme != G_ARRAY) {
796 SAVEVPTR(PL_sortcop);
797 if (PL_op->op_flags & OPf_STACKED) {
798 if (PL_op->op_flags & OPf_SPECIAL) {
799 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
800 kid = kUNOP->op_first; /* pass rv2gv */
801 kid = kUNOP->op_first; /* pass leave */
802 PL_sortcop = kid->op_next;
803 stash = CopSTASH(PL_curcop);
806 cv = sv_2cv(*++MARK, &stash, &gv, 0);
807 if (cv && SvPOK(cv)) {
809 char *proto = SvPV((SV*)cv, n_a);
810 if (proto && strEQ(proto, "$$")) {
814 if (!(cv && CvROOT(cv))) {
815 if (cv && CvXSUB(cv)) {
819 SV *tmpstr = sv_newmortal();
820 gv_efullname3(tmpstr, gv, Nullch);
821 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
825 DIE(aTHX_ "Undefined subroutine in sort");
830 PL_sortcop = (OP*)cv;
832 PL_sortcop = CvSTART(cv);
833 SAVEVPTR(CvROOT(cv)->op_ppaddr);
834 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
837 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
843 stash = CopSTASH(PL_curcop);
847 while (MARK < SP) { /* This may or may not shift down one here. */
849 if (*up = *++MARK) { /* Weed out nulls. */
851 if (!PL_sortcop && !SvPOK(*up)) {
856 (void)sv_2pv(*up, &n_a);
861 max = --up - myorigmark;
866 bool oldcatch = CATCH_GET;
872 PUSHSTACKi(PERLSI_SORT);
873 if (PL_sortstash != stash) {
874 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
875 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
876 PL_sortstash = stash;
879 SAVESPTR(GvSV(PL_firstgv));
880 SAVESPTR(GvSV(PL_secondgv));
882 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
883 if (!(PL_op->op_flags & OPf_SPECIAL)) {
884 cx->cx_type = CXt_SUB;
885 cx->blk_gimme = G_SCALAR;
888 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
890 PL_sortcxix = cxstack_ix;
892 if (hasargs && !is_xsub) {
893 /* This is mostly copied from pp_entersub */
894 AV *av = (AV*)PL_curpad[0];
897 cx->blk_sub.savearray = GvAV(PL_defgv);
898 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
899 #endif /* USE_THREADS */
900 cx->blk_sub.argarray = av;
902 qsortsv((myorigmark+1), max,
903 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
905 POPBLOCK(cx,PL_curpm);
913 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
914 qsortsv(ORIGMARK+1, max,
915 (PL_op->op_private & OPpSORT_NUMERIC)
916 ? ( (PL_op->op_private & OPpSORT_INTEGER)
917 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
918 : ( overloading ? amagic_ncmp : sv_ncmp))
919 : ( (PL_op->op_private & OPpLOCALE)
922 : sv_cmp_locale_static)
923 : ( overloading ? amagic_cmp : sv_cmp_static)));
924 if (PL_op->op_private & OPpSORT_REVERSE) {
926 SV **q = ORIGMARK+max;
936 PL_stack_sp = ORIGMARK + max;
944 if (GIMME == G_ARRAY)
946 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
947 return cLOGOP->op_other;
956 if (GIMME == G_ARRAY) {
957 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
961 SV *targ = PAD_SV(PL_op->op_targ);
963 if ((PL_op->op_private & OPpFLIP_LINENUM)
964 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
966 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
967 if (PL_op->op_flags & OPf_SPECIAL) {
975 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
988 if (GIMME == G_ARRAY) {
994 if (SvGMAGICAL(left))
996 if (SvGMAGICAL(right))
999 if (SvNIOKp(left) || !SvPOKp(left) ||
1000 (looks_like_number(left) && *SvPVX(left) != '0') )
1002 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1003 DIE(aTHX_ "Range iterator outside integer range");
1014 sv = sv_2mortal(newSViv(i++));
1019 SV *final = sv_mortalcopy(right);
1021 char *tmps = SvPV(final, len);
1023 sv = sv_mortalcopy(left);
1025 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1027 if (strEQ(SvPVX(sv),tmps))
1029 sv = sv_2mortal(newSVsv(sv));
1036 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1038 if ((PL_op->op_private & OPpFLIP_LINENUM)
1039 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1041 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1042 sv_catpv(targ, "E0");
1053 S_dopoptolabel(pTHX_ char *label)
1057 register PERL_CONTEXT *cx;
1059 for (i = cxstack_ix; i >= 0; i--) {
1061 switch (CxTYPE(cx)) {
1063 if (ckWARN(WARN_UNSAFE))
1064 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1065 PL_op_name[PL_op->op_type]);
1068 if (ckWARN(WARN_UNSAFE))
1069 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1070 PL_op_name[PL_op->op_type]);
1073 if (ckWARN(WARN_UNSAFE))
1074 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1075 PL_op_name[PL_op->op_type]);
1078 if (ckWARN(WARN_UNSAFE))
1079 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1080 PL_op_name[PL_op->op_type]);
1083 if (ckWARN(WARN_UNSAFE))
1084 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1085 PL_op_name[PL_op->op_type]);
1088 if (!cx->blk_loop.label ||
1089 strNE(label, cx->blk_loop.label) ) {
1090 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1091 (long)i, cx->blk_loop.label));
1094 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1102 Perl_dowantarray(pTHX)
1104 I32 gimme = block_gimme();
1105 return (gimme == G_VOID) ? G_SCALAR : gimme;
1109 Perl_block_gimme(pTHX)
1114 cxix = dopoptosub(cxstack_ix);
1118 switch (cxstack[cxix].blk_gimme) {
1126 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1133 S_dopoptosub(pTHX_ I32 startingblock)
1136 return dopoptosub_at(cxstack, startingblock);
1140 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1144 register PERL_CONTEXT *cx;
1145 for (i = startingblock; i >= 0; i--) {
1147 switch (CxTYPE(cx)) {
1153 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1161 S_dopoptoeval(pTHX_ I32 startingblock)
1165 register PERL_CONTEXT *cx;
1166 for (i = startingblock; i >= 0; i--) {
1168 switch (CxTYPE(cx)) {
1172 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1180 S_dopoptoloop(pTHX_ I32 startingblock)
1184 register PERL_CONTEXT *cx;
1185 for (i = startingblock; i >= 0; i--) {
1187 switch (CxTYPE(cx)) {
1189 if (ckWARN(WARN_UNSAFE))
1190 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1191 PL_op_name[PL_op->op_type]);
1194 if (ckWARN(WARN_UNSAFE))
1195 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1196 PL_op_name[PL_op->op_type]);
1199 if (ckWARN(WARN_UNSAFE))
1200 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1201 PL_op_name[PL_op->op_type]);
1204 if (ckWARN(WARN_UNSAFE))
1205 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1206 PL_op_name[PL_op->op_type]);
1209 if (ckWARN(WARN_UNSAFE))
1210 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1211 PL_op_name[PL_op->op_type]);
1214 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1222 Perl_dounwind(pTHX_ I32 cxix)
1225 register PERL_CONTEXT *cx;
1229 while (cxstack_ix > cxix) {
1231 cx = &cxstack[cxstack_ix];
1232 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1233 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1234 /* Note: we don't need to restore the base context info till the end. */
1235 switch (CxTYPE(cx)) {
1238 continue; /* not break */
1260 * Closures mentioned at top level of eval cannot be referenced
1261 * again, and their presence indirectly causes a memory leak.
1262 * (Note that the fact that compcv and friends are still set here
1263 * is, AFAIK, an accident.) --Chip
1265 * XXX need to get comppad et al from eval's cv rather than
1266 * relying on the incidental global values.
1269 S_free_closures(pTHX)
1272 SV **svp = AvARRAY(PL_comppad_name);
1274 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1276 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1278 svp[ix] = &PL_sv_undef;
1282 SvREFCNT_dec(CvOUTSIDE(sv));
1283 CvOUTSIDE(sv) = Nullcv;
1296 Perl_qerror(pTHX_ SV *err)
1299 sv_catsv(ERRSV, err);
1301 sv_catsv(PL_errors, err);
1303 Perl_warn(aTHX_ "%_", err);
1308 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1314 register PERL_CONTEXT *cx;
1319 if (PL_in_eval & EVAL_KEEPERR) {
1320 static char prefix[] = "\t(in cleanup) ";
1325 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1328 if (*e != *message || strNE(e,message))
1332 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1333 sv_catpvn(err, prefix, sizeof(prefix)-1);
1334 sv_catpvn(err, message, msglen);
1335 if (ckWARN(WARN_UNSAFE)) {
1336 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1337 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1342 sv_setpvn(ERRSV, message, msglen);
1345 message = SvPVx(ERRSV, msglen);
1347 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1348 && PL_curstackinfo->si_prev)
1357 if (cxix < cxstack_ix)
1360 POPBLOCK(cx,PL_curpm);
1361 if (CxTYPE(cx) != CXt_EVAL) {
1362 PerlIO_write(Perl_error_log, "panic: die ", 11);
1363 PerlIO_write(Perl_error_log, message, msglen);
1368 if (gimme == G_SCALAR)
1369 *++newsp = &PL_sv_undef;
1370 PL_stack_sp = newsp;
1374 if (optype == OP_REQUIRE) {
1375 char* msg = SvPVx(ERRSV, n_a);
1376 DIE(aTHX_ "%sCompilation failed in require",
1377 *msg ? msg : "Unknown error\n");
1379 return pop_return();
1383 message = SvPVx(ERRSV, msglen);
1386 /* SFIO can really mess with your errno */
1389 PerlIO *serr = Perl_error_log;
1391 PerlIO_write(serr, message, msglen);
1392 (void)PerlIO_flush(serr);
1405 if (SvTRUE(left) != SvTRUE(right))
1417 RETURNOP(cLOGOP->op_other);
1426 RETURNOP(cLOGOP->op_other);
1432 register I32 cxix = dopoptosub(cxstack_ix);
1433 register PERL_CONTEXT *cx;
1434 register PERL_CONTEXT *ccstack = cxstack;
1435 PERL_SI *top_si = PL_curstackinfo;
1446 /* we may be in a higher stacklevel, so dig down deeper */
1447 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1448 top_si = top_si->si_prev;
1449 ccstack = top_si->si_cxstack;
1450 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1453 if (GIMME != G_ARRAY)
1457 if (PL_DBsub && cxix >= 0 &&
1458 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1462 cxix = dopoptosub_at(ccstack, cxix - 1);
1465 cx = &ccstack[cxix];
1466 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1467 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1468 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1469 field below is defined for any cx. */
1470 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1471 cx = &ccstack[dbcxix];
1474 stashname = CopSTASHPV(cx->blk_oldcop);
1475 if (GIMME != G_ARRAY) {
1477 PUSHs(&PL_sv_undef);
1480 sv_setpv(TARG, stashname);
1487 PUSHs(&PL_sv_undef);
1489 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1490 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1491 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1494 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1495 /* So is ccstack[dbcxix]. */
1497 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1498 PUSHs(sv_2mortal(sv));
1499 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1502 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1503 PUSHs(sv_2mortal(newSViv(0)));
1505 gimme = (I32)cx->blk_gimme;
1506 if (gimme == G_VOID)
1507 PUSHs(&PL_sv_undef);
1509 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1510 if (CxTYPE(cx) == CXt_EVAL) {
1511 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1512 PUSHs(cx->blk_eval.cur_text);
1515 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1516 /* Require, put the name. */
1517 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1522 PUSHs(&PL_sv_undef);
1523 PUSHs(&PL_sv_undef);
1525 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1526 && CopSTASH_eq(PL_curcop, PL_debstash))
1528 AV *ary = cx->blk_sub.argarray;
1529 int off = AvARRAY(ary) - AvALLOC(ary);
1533 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1536 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1539 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1540 av_extend(PL_dbargs, AvFILLp(ary) + off);
1541 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1542 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1544 /* XXX only hints propagated via op_private are currently
1545 * visible (others are not easily accessible, since they
1546 * use the global PL_hints) */
1547 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1548 HINT_PRIVATE_MASK)));
1562 sv_reset(tmps, CopSTASH(PL_curcop));
1574 PL_curcop = (COP*)PL_op;
1575 TAINT_NOT; /* Each statement is presumed innocent */
1576 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1579 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1583 register PERL_CONTEXT *cx;
1584 I32 gimme = G_ARRAY;
1591 DIE(aTHX_ "No DB::DB routine defined");
1593 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1605 push_return(PL_op->op_next);
1606 PUSHBLOCK(cx, CXt_SUB, SP);
1609 (void)SvREFCNT_inc(cv);
1610 SAVEVPTR(PL_curpad);
1611 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1612 RETURNOP(CvSTART(cv));
1626 register PERL_CONTEXT *cx;
1627 I32 gimme = GIMME_V;
1629 U32 cxtype = CXt_LOOP;
1638 if (PL_op->op_flags & OPf_SPECIAL) {
1640 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1641 SAVEGENERICSV(*svp);
1645 #endif /* USE_THREADS */
1646 if (PL_op->op_targ) {
1647 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1650 iterdata = (void*)PL_op->op_targ;
1651 cxtype |= CXp_PADVAR;
1656 svp = &GvSV(gv); /* symbol table variable */
1657 SAVEGENERICSV(*svp);
1660 iterdata = (void*)gv;
1666 PUSHBLOCK(cx, cxtype, SP);
1668 PUSHLOOP(cx, iterdata, MARK);
1670 PUSHLOOP(cx, svp, MARK);
1672 if (PL_op->op_flags & OPf_STACKED) {
1673 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1674 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1676 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1677 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1678 if (SvNV(sv) < IV_MIN ||
1679 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1680 DIE(aTHX_ "Range iterator outside integer range");
1681 cx->blk_loop.iterix = SvIV(sv);
1682 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1685 cx->blk_loop.iterlval = newSVsv(sv);
1689 cx->blk_loop.iterary = PL_curstack;
1690 AvFILLp(PL_curstack) = SP - PL_stack_base;
1691 cx->blk_loop.iterix = MARK - PL_stack_base;
1700 register PERL_CONTEXT *cx;
1701 I32 gimme = GIMME_V;
1707 PUSHBLOCK(cx, CXt_LOOP, SP);
1708 PUSHLOOP(cx, 0, SP);
1716 register PERL_CONTEXT *cx;
1724 newsp = PL_stack_base + cx->blk_loop.resetsp;
1727 if (gimme == G_VOID)
1729 else if (gimme == G_SCALAR) {
1731 *++newsp = sv_mortalcopy(*SP);
1733 *++newsp = &PL_sv_undef;
1737 *++newsp = sv_mortalcopy(*++mark);
1738 TAINT_NOT; /* Each item is independent */
1744 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1745 PL_curpm = newpm; /* ... and pop $1 et al */
1757 register PERL_CONTEXT *cx;
1758 bool popsub2 = FALSE;
1765 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1766 if (cxstack_ix == PL_sortcxix
1767 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1769 if (cxstack_ix > PL_sortcxix)
1770 dounwind(PL_sortcxix);
1771 AvARRAY(PL_curstack)[1] = *SP;
1772 PL_stack_sp = PL_stack_base + 1;
1777 cxix = dopoptosub(cxstack_ix);
1779 DIE(aTHX_ "Can't return outside a subroutine");
1780 if (cxix < cxstack_ix)
1784 switch (CxTYPE(cx)) {
1790 if (AvFILLp(PL_comppad_name) >= 0)
1793 if (optype == OP_REQUIRE &&
1794 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1796 /* Unassume the success we assumed earlier. */
1797 char *name = cx->blk_eval.old_name;
1798 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1799 DIE(aTHX_ "%s did not return a true value", name);
1806 DIE(aTHX_ "panic: return");
1810 if (gimme == G_SCALAR) {
1813 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1815 *++newsp = SvREFCNT_inc(*SP);
1820 *++newsp = sv_mortalcopy(*SP);
1823 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1825 *++newsp = sv_mortalcopy(*SP);
1827 *++newsp = &PL_sv_undef;
1829 else if (gimme == G_ARRAY) {
1830 while (++MARK <= SP) {
1831 *++newsp = (popsub2 && SvTEMP(*MARK))
1832 ? *MARK : sv_mortalcopy(*MARK);
1833 TAINT_NOT; /* Each item is independent */
1836 PL_stack_sp = newsp;
1838 /* Stack values are safe: */
1840 POPSUB(cx,sv); /* release CV and @_ ... */
1844 PL_curpm = newpm; /* ... and pop $1 et al */
1848 return pop_return();
1855 register PERL_CONTEXT *cx;
1865 if (PL_op->op_flags & OPf_SPECIAL) {
1866 cxix = dopoptoloop(cxstack_ix);
1868 DIE(aTHX_ "Can't \"last\" outside a loop block");
1871 cxix = dopoptolabel(cPVOP->op_pv);
1873 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1875 if (cxix < cxstack_ix)
1880 switch (CxTYPE(cx)) {
1883 newsp = PL_stack_base + cx->blk_loop.resetsp;
1884 nextop = cx->blk_loop.last_op->op_next;
1888 nextop = pop_return();
1892 nextop = pop_return();
1896 nextop = pop_return();
1899 DIE(aTHX_ "panic: last");
1903 if (gimme == G_SCALAR) {
1905 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1906 ? *SP : sv_mortalcopy(*SP);
1908 *++newsp = &PL_sv_undef;
1910 else if (gimme == G_ARRAY) {
1911 while (++MARK <= SP) {
1912 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1913 ? *MARK : sv_mortalcopy(*MARK);
1914 TAINT_NOT; /* Each item is independent */
1920 /* Stack values are safe: */
1923 POPLOOP(cx); /* release loop vars ... */
1927 POPSUB(cx,sv); /* release CV and @_ ... */
1930 PL_curpm = newpm; /* ... and pop $1 et al */
1940 register PERL_CONTEXT *cx;
1943 if (PL_op->op_flags & OPf_SPECIAL) {
1944 cxix = dopoptoloop(cxstack_ix);
1946 DIE(aTHX_ "Can't \"next\" outside a loop block");
1949 cxix = dopoptolabel(cPVOP->op_pv);
1951 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1953 if (cxix < cxstack_ix)
1957 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1958 LEAVE_SCOPE(oldsave);
1959 return cx->blk_loop.next_op;
1965 register PERL_CONTEXT *cx;
1968 if (PL_op->op_flags & OPf_SPECIAL) {
1969 cxix = dopoptoloop(cxstack_ix);
1971 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1974 cxix = dopoptolabel(cPVOP->op_pv);
1976 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1978 if (cxix < cxstack_ix)
1982 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1983 LEAVE_SCOPE(oldsave);
1984 return cx->blk_loop.redo_op;
1988 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1992 static char too_deep[] = "Target of goto is too deeply nested";
1995 Perl_croak(aTHX_ too_deep);
1996 if (o->op_type == OP_LEAVE ||
1997 o->op_type == OP_SCOPE ||
1998 o->op_type == OP_LEAVELOOP ||
1999 o->op_type == OP_LEAVETRY)
2001 *ops++ = cUNOPo->op_first;
2003 Perl_croak(aTHX_ too_deep);
2006 if (o->op_flags & OPf_KIDS) {
2008 /* First try all the kids at this level, since that's likeliest. */
2009 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2010 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2011 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2014 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2015 if (kid == PL_lastgotoprobe)
2017 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2019 (ops[-1]->op_type != OP_NEXTSTATE &&
2020 ops[-1]->op_type != OP_DBSTATE)))
2022 if (o = dofindlabel(kid, label, ops, oplimit))
2041 register PERL_CONTEXT *cx;
2042 #define GOTO_DEPTH 64
2043 OP *enterops[GOTO_DEPTH];
2045 int do_dump = (PL_op->op_type == OP_DUMP);
2046 static char must_have_label[] = "goto must have label";
2049 if (PL_op->op_flags & OPf_STACKED) {
2053 /* This egregious kludge implements goto &subroutine */
2054 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2056 register PERL_CONTEXT *cx;
2057 CV* cv = (CV*)SvRV(sv);
2063 if (!CvROOT(cv) && !CvXSUB(cv)) {
2068 /* autoloaded stub? */
2069 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2071 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2072 GvNAMELEN(gv), FALSE);
2073 if (autogv && (cv = GvCV(autogv)))
2075 tmpstr = sv_newmortal();
2076 gv_efullname3(tmpstr, gv, Nullch);
2077 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2079 DIE(aTHX_ "Goto undefined subroutine");
2082 /* First do some returnish stuff. */
2083 cxix = dopoptosub(cxstack_ix);
2085 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2086 if (cxix < cxstack_ix)
2089 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2090 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2092 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2093 /* put @_ back onto stack */
2094 AV* av = cx->blk_sub.argarray;
2096 items = AvFILLp(av) + 1;
2098 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2099 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2100 PL_stack_sp += items;
2102 SvREFCNT_dec(GvAV(PL_defgv));
2103 GvAV(PL_defgv) = cx->blk_sub.savearray;
2104 #endif /* USE_THREADS */
2105 /* abandon @_ if it got reified */
2107 (void)sv_2mortal((SV*)av); /* delay until return */
2109 av_extend(av, items-1);
2110 AvFLAGS(av) = AVf_REIFY;
2111 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2114 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2118 av = (AV*)PL_curpad[0];
2120 av = GvAV(PL_defgv);
2122 items = AvFILLp(av) + 1;
2124 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2125 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2126 PL_stack_sp += items;
2128 if (CxTYPE(cx) == CXt_SUB &&
2129 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2130 SvREFCNT_dec(cx->blk_sub.cv);
2131 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2132 LEAVE_SCOPE(oldsave);
2134 /* Now do some callish stuff. */
2137 #ifdef PERL_XSUB_OLDSTYLE
2138 if (CvOLDSTYLE(cv)) {
2139 I32 (*fp3)(int,int,int);
2144 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2145 items = (*fp3)(CvXSUBANY(cv).any_i32,
2146 mark - PL_stack_base + 1,
2148 SP = PL_stack_base + items;
2151 #endif /* PERL_XSUB_OLDSTYLE */
2156 PL_stack_sp--; /* There is no cv arg. */
2157 /* Push a mark for the start of arglist */
2159 (void)(*CvXSUB(cv))(aTHXo_ cv);
2160 /* Pop the current context like a decent sub should */
2161 POPBLOCK(cx, PL_curpm);
2162 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2165 return pop_return();
2168 AV* padlist = CvPADLIST(cv);
2169 SV** svp = AvARRAY(padlist);
2170 if (CxTYPE(cx) == CXt_EVAL) {
2171 PL_in_eval = cx->blk_eval.old_in_eval;
2172 PL_eval_root = cx->blk_eval.old_eval_root;
2173 cx->cx_type = CXt_SUB;
2174 cx->blk_sub.hasargs = 0;
2176 cx->blk_sub.cv = cv;
2177 cx->blk_sub.olddepth = CvDEPTH(cv);
2179 if (CvDEPTH(cv) < 2)
2180 (void)SvREFCNT_inc(cv);
2181 else { /* save temporaries on recursion? */
2182 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2183 sub_crush_depth(cv);
2184 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2185 AV *newpad = newAV();
2186 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2187 I32 ix = AvFILLp((AV*)svp[1]);
2188 I32 names_fill = AvFILLp((AV*)svp[0]);
2189 svp = AvARRAY(svp[0]);
2190 for ( ;ix > 0; ix--) {
2191 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2192 char *name = SvPVX(svp[ix]);
2193 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2196 /* outer lexical or anon code */
2197 av_store(newpad, ix,
2198 SvREFCNT_inc(oldpad[ix]) );
2200 else { /* our own lexical */
2202 av_store(newpad, ix, sv = (SV*)newAV());
2203 else if (*name == '%')
2204 av_store(newpad, ix, sv = (SV*)newHV());
2206 av_store(newpad, ix, sv = NEWSV(0,0));
2210 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2211 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2214 av_store(newpad, ix, sv = NEWSV(0,0));
2218 if (cx->blk_sub.hasargs) {
2221 av_store(newpad, 0, (SV*)av);
2222 AvFLAGS(av) = AVf_REIFY;
2224 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2225 AvFILLp(padlist) = CvDEPTH(cv);
2226 svp = AvARRAY(padlist);
2230 if (!cx->blk_sub.hasargs) {
2231 AV* av = (AV*)PL_curpad[0];
2233 items = AvFILLp(av) + 1;
2235 /* Mark is at the end of the stack. */
2237 Copy(AvARRAY(av), SP + 1, items, SV*);
2242 #endif /* USE_THREADS */
2243 SAVEVPTR(PL_curpad);
2244 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2246 if (cx->blk_sub.hasargs)
2247 #endif /* USE_THREADS */
2249 AV* av = (AV*)PL_curpad[0];
2253 cx->blk_sub.savearray = GvAV(PL_defgv);
2254 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2255 #endif /* USE_THREADS */
2256 cx->blk_sub.argarray = av;
2259 if (items >= AvMAX(av) + 1) {
2261 if (AvARRAY(av) != ary) {
2262 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2263 SvPVX(av) = (char*)ary;
2265 if (items >= AvMAX(av) + 1) {
2266 AvMAX(av) = items - 1;
2267 Renew(ary,items+1,SV*);
2269 SvPVX(av) = (char*)ary;
2272 Copy(mark,AvARRAY(av),items,SV*);
2273 AvFILLp(av) = items - 1;
2274 assert(!AvREAL(av));
2281 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2283 * We do not care about using sv to call CV;
2284 * it's for informational purposes only.
2286 SV *sv = GvSV(PL_DBsub);
2289 if (PERLDB_SUB_NN) {
2290 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2293 gv_efullname3(sv, CvGV(cv), Nullch);
2296 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2297 PUSHMARK( PL_stack_sp );
2298 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2302 RETURNOP(CvSTART(cv));
2306 label = SvPV(sv,n_a);
2307 if (!(do_dump || *label))
2308 DIE(aTHX_ must_have_label);
2311 else if (PL_op->op_flags & OPf_SPECIAL) {
2313 DIE(aTHX_ must_have_label);
2316 label = cPVOP->op_pv;
2318 if (label && *label) {
2323 PL_lastgotoprobe = 0;
2325 for (ix = cxstack_ix; ix >= 0; ix--) {
2327 switch (CxTYPE(cx)) {
2329 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2332 gotoprobe = cx->blk_oldcop->op_sibling;
2338 gotoprobe = cx->blk_oldcop->op_sibling;
2340 gotoprobe = PL_main_root;
2343 if (CvDEPTH(cx->blk_sub.cv)) {
2344 gotoprobe = CvROOT(cx->blk_sub.cv);
2350 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2353 DIE(aTHX_ "panic: goto");
2354 gotoprobe = PL_main_root;
2357 retop = dofindlabel(gotoprobe, label,
2358 enterops, enterops + GOTO_DEPTH);
2361 PL_lastgotoprobe = gotoprobe;
2364 DIE(aTHX_ "Can't find label %s", label);
2366 /* pop unwanted frames */
2368 if (ix < cxstack_ix) {
2375 oldsave = PL_scopestack[PL_scopestack_ix];
2376 LEAVE_SCOPE(oldsave);
2379 /* push wanted frames */
2381 if (*enterops && enterops[1]) {
2383 for (ix = 1; enterops[ix]; ix++) {
2384 PL_op = enterops[ix];
2385 /* Eventually we may want to stack the needed arguments
2386 * for each op. For now, we punt on the hard ones. */
2387 if (PL_op->op_type == OP_ENTERITER)
2388 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2390 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2398 if (!retop) retop = PL_main_start;
2400 PL_restartop = retop;
2401 PL_do_undump = TRUE;
2405 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2406 PL_do_undump = FALSE;
2422 if (anum == 1 && VMSISH_EXIT)
2426 PL_exit_flags |= PERL_EXIT_EXPECTED;
2428 PUSHs(&PL_sv_undef);
2436 NV value = SvNVx(GvSV(cCOP->cop_gv));
2437 register I32 match = I_32(value);
2440 if (((NV)match) > value)
2441 --match; /* was fractional--truncate other way */
2443 match -= cCOP->uop.scop.scop_offset;
2446 else if (match > cCOP->uop.scop.scop_max)
2447 match = cCOP->uop.scop.scop_max;
2448 PL_op = cCOP->uop.scop.scop_next[match];
2458 PL_op = PL_op->op_next; /* can't assume anything */
2461 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2462 match -= cCOP->uop.scop.scop_offset;
2465 else if (match > cCOP->uop.scop.scop_max)
2466 match = cCOP->uop.scop.scop_max;
2467 PL_op = cCOP->uop.scop.scop_next[match];
2476 S_save_lines(pTHX_ AV *array, SV *sv)
2478 register char *s = SvPVX(sv);
2479 register char *send = SvPVX(sv) + SvCUR(sv);
2481 register I32 line = 1;
2483 while (s && s < send) {
2484 SV *tmpstr = NEWSV(85,0);
2486 sv_upgrade(tmpstr, SVt_PVMG);
2487 t = strchr(s, '\n');
2493 sv_setpvn(tmpstr, s, t - s);
2494 av_store(array, line++, tmpstr);
2500 S_docatch_body(pTHX_ va_list args)
2507 S_docatch(pTHX_ OP *o)
2512 volatile PERL_SI *cursi = PL_curstackinfo;
2516 assert(CATCH_GET == TRUE);
2520 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2525 if (PL_restartop && cursi == PL_curstackinfo) {
2526 PL_op = PL_restartop;
2541 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2542 /* sv Text to convert to OP tree. */
2543 /* startop op_free() this to undo. */
2544 /* code Short string id of the caller. */
2546 dSP; /* Make POPBLOCK work. */
2549 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2552 OP *oop = PL_op, *rop;
2553 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2559 /* switch to eval mode */
2561 if (PL_curcop == &PL_compiling) {
2562 SAVECOPSTASH(&PL_compiling);
2563 CopSTASH_set(&PL_compiling, PL_curstash);
2565 SAVECOPFILE(&PL_compiling);
2566 SAVECOPLINE(&PL_compiling);
2567 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2568 CopFILE_set(&PL_compiling, tmpbuf+2);
2569 CopLINE_set(&PL_compiling, 1);
2570 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2571 deleting the eval's FILEGV from the stash before gv_check() runs
2572 (i.e. before run-time proper). To work around the coredump that
2573 ensues, we always turn GvMULTI_on for any globals that were
2574 introduced within evals. See force_ident(). GSAR 96-10-12 */
2575 safestr = savepv(tmpbuf);
2576 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2578 #ifdef OP_IN_REGISTER
2586 PL_op->op_type = OP_ENTEREVAL;
2587 PL_op->op_flags = 0; /* Avoid uninit warning. */
2588 PUSHBLOCK(cx, CXt_EVAL, SP);
2589 PUSHEVAL(cx, 0, Nullgv);
2590 rop = doeval(G_SCALAR, startop);
2591 POPBLOCK(cx,PL_curpm);
2594 (*startop)->op_type = OP_NULL;
2595 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2597 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2599 if (PL_curcop == &PL_compiling)
2600 PL_compiling.op_private = PL_hints;
2601 #ifdef OP_IN_REGISTER
2607 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2609 S_doeval(pTHX_ int gimme, OP** startop)
2617 PL_in_eval = EVAL_INEVAL;
2621 /* set up a scratch pad */
2624 SAVEVPTR(PL_curpad);
2625 SAVESPTR(PL_comppad);
2626 SAVESPTR(PL_comppad_name);
2627 SAVEI32(PL_comppad_name_fill);
2628 SAVEI32(PL_min_intro_pending);
2629 SAVEI32(PL_max_intro_pending);
2632 for (i = cxstack_ix - 1; i >= 0; i--) {
2633 PERL_CONTEXT *cx = &cxstack[i];
2634 if (CxTYPE(cx) == CXt_EVAL)
2636 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2637 caller = cx->blk_sub.cv;
2642 SAVESPTR(PL_compcv);
2643 PL_compcv = (CV*)NEWSV(1104,0);
2644 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2645 CvEVAL_on(PL_compcv);
2647 CvOWNER(PL_compcv) = 0;
2648 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2649 MUTEX_INIT(CvMUTEXP(PL_compcv));
2650 #endif /* USE_THREADS */
2652 PL_comppad = newAV();
2653 av_push(PL_comppad, Nullsv);
2654 PL_curpad = AvARRAY(PL_comppad);
2655 PL_comppad_name = newAV();
2656 PL_comppad_name_fill = 0;
2657 PL_min_intro_pending = 0;
2660 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2661 PL_curpad[0] = (SV*)newAV();
2662 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2663 #endif /* USE_THREADS */
2665 comppadlist = newAV();
2666 AvREAL_off(comppadlist);
2667 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2668 av_store(comppadlist, 1, (SV*)PL_comppad);
2669 CvPADLIST(PL_compcv) = comppadlist;
2671 if (!saveop || saveop->op_type != OP_REQUIRE)
2672 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2674 SAVEFREESV(PL_compcv);
2676 /* make sure we compile in the right package */
2678 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2679 SAVESPTR(PL_curstash);
2680 PL_curstash = CopSTASH(PL_curcop);
2682 SAVESPTR(PL_beginav);
2683 PL_beginav = newAV();
2684 SAVEFREESV(PL_beginav);
2686 /* try to compile it */
2688 PL_eval_root = Nullop;
2690 PL_curcop = &PL_compiling;
2691 PL_curcop->cop_arybase = 0;
2692 SvREFCNT_dec(PL_rs);
2693 PL_rs = newSVpvn("\n", 1);
2694 if (saveop && saveop->op_flags & OPf_SPECIAL)
2695 PL_in_eval |= EVAL_KEEPERR;
2698 if (yyparse() || PL_error_count || !PL_eval_root) {
2702 I32 optype = 0; /* Might be reset by POPEVAL. */
2707 op_free(PL_eval_root);
2708 PL_eval_root = Nullop;
2710 SP = PL_stack_base + POPMARK; /* pop original mark */
2712 POPBLOCK(cx,PL_curpm);
2718 if (optype == OP_REQUIRE) {
2719 char* msg = SvPVx(ERRSV, n_a);
2720 DIE(aTHX_ "%sCompilation failed in require",
2721 *msg ? msg : "Unknown error\n");
2724 char* msg = SvPVx(ERRSV, n_a);
2726 POPBLOCK(cx,PL_curpm);
2728 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2729 (*msg ? msg : "Unknown error\n"));
2731 SvREFCNT_dec(PL_rs);
2732 PL_rs = SvREFCNT_inc(PL_nrs);
2734 MUTEX_LOCK(&PL_eval_mutex);
2736 COND_SIGNAL(&PL_eval_cond);
2737 MUTEX_UNLOCK(&PL_eval_mutex);
2738 #endif /* USE_THREADS */
2741 SvREFCNT_dec(PL_rs);
2742 PL_rs = SvREFCNT_inc(PL_nrs);
2743 CopLINE_set(&PL_compiling, 0);
2745 *startop = PL_eval_root;
2746 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2747 CvOUTSIDE(PL_compcv) = Nullcv;
2749 SAVEFREEOP(PL_eval_root);
2751 scalarvoid(PL_eval_root);
2752 else if (gimme & G_ARRAY)
2755 scalar(PL_eval_root);
2757 DEBUG_x(dump_eval());
2759 /* Register with debugger: */
2760 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2761 CV *cv = get_cv("DB::postponed", FALSE);
2765 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2767 call_sv((SV*)cv, G_DISCARD);
2771 /* compiled okay, so do it */
2773 CvDEPTH(PL_compcv) = 1;
2774 SP = PL_stack_base + POPMARK; /* pop original mark */
2775 PL_op = saveop; /* The caller may need it. */
2777 MUTEX_LOCK(&PL_eval_mutex);
2779 COND_SIGNAL(&PL_eval_cond);
2780 MUTEX_UNLOCK(&PL_eval_mutex);
2781 #endif /* USE_THREADS */
2783 RETURNOP(PL_eval_start);
2787 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2789 STRLEN namelen = strlen(name);
2792 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2793 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2794 char *pmc = SvPV_nolen(pmcsv);
2797 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2798 fp = PerlIO_open(name, mode);
2801 if (PerlLIO_stat(name, &pmstat) < 0 ||
2802 pmstat.st_mtime < pmcstat.st_mtime)
2804 fp = PerlIO_open(pmc, mode);
2807 fp = PerlIO_open(name, mode);
2810 SvREFCNT_dec(pmcsv);
2813 fp = PerlIO_open(name, mode);
2821 register PERL_CONTEXT *cx;
2826 SV *namesv = Nullsv;
2828 I32 gimme = G_SCALAR;
2829 PerlIO *tryrsfp = 0;
2831 int filter_has_file = 0;
2832 GV *filter_child_proc = 0;
2833 SV *filter_state = 0;
2837 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2838 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2839 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2840 SvPV(sv,n_a),PL_patchlevel);
2843 name = SvPV(sv, len);
2844 if (!(name && len > 0 && *name))
2845 DIE(aTHX_ "Null filename used");
2846 TAINT_PROPER("require");
2847 if (PL_op->op_type == OP_REQUIRE &&
2848 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2849 *svp != &PL_sv_undef)
2852 /* prepare to compile file */
2854 if (PERL_FILE_IS_ABSOLUTE(name)
2855 || (*name == '.' && (name[1] == '/' ||
2856 (name[1] == '.' && name[2] == '/'))))
2859 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2862 AV *ar = GvAVn(PL_incgv);
2866 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2869 namesv = NEWSV(806, 0);
2870 for (i = 0; i <= AvFILL(ar); i++) {
2871 SV *dirsv = *av_fetch(ar, i, TRUE);
2877 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2878 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2881 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2882 PTR2UV(SvANY(loader)), name);
2883 tryname = SvPVX(namesv);
2894 count = call_sv(loader, G_ARRAY);
2904 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2908 if (SvTYPE(arg) == SVt_PVGV) {
2909 IO *io = GvIO((GV *)arg);
2914 tryrsfp = IoIFP(io);
2915 if (IoTYPE(io) == '|') {
2916 /* reading from a child process doesn't
2917 nest -- when returning from reading
2918 the inner module, the outer one is
2919 unreadable (closed?) I've tried to
2920 save the gv to manage the lifespan of
2921 the pipe, but this didn't help. XXX */
2922 filter_child_proc = (GV *)arg;
2923 (void)SvREFCNT_inc(filter_child_proc);
2926 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2927 PerlIO_close(IoOFP(io));
2939 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2941 (void)SvREFCNT_inc(filter_sub);
2944 filter_state = SP[i];
2945 (void)SvREFCNT_inc(filter_state);
2949 tryrsfp = PerlIO_open("/dev/null",
2963 filter_has_file = 0;
2964 if (filter_child_proc) {
2965 SvREFCNT_dec(filter_child_proc);
2966 filter_child_proc = 0;
2969 SvREFCNT_dec(filter_state);
2973 SvREFCNT_dec(filter_sub);
2978 char *dir = SvPVx(dirsv, n_a);
2981 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2983 sv_setpv(namesv, unixdir);
2984 sv_catpv(namesv, unixname);
2986 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2988 TAINT_PROPER("require");
2989 tryname = SvPVX(namesv);
2990 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2992 if (tryname[0] == '.' && tryname[1] == '/')
3000 SAVECOPFILE(&PL_compiling);
3001 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3002 SvREFCNT_dec(namesv);
3004 if (PL_op->op_type == OP_REQUIRE) {
3005 char *msgstr = name;
3006 if (namesv) { /* did we lookup @INC? */
3007 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3008 SV *dirmsgsv = NEWSV(0, 0);
3009 AV *ar = GvAVn(PL_incgv);
3011 sv_catpvn(msg, " in @INC", 8);
3012 if (instr(SvPVX(msg), ".h "))
3013 sv_catpv(msg, " (change .h to .ph maybe?)");
3014 if (instr(SvPVX(msg), ".ph "))
3015 sv_catpv(msg, " (did you run h2ph?)");
3016 sv_catpv(msg, " (@INC contains:");
3017 for (i = 0; i <= AvFILL(ar); i++) {
3018 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3019 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3020 sv_catsv(msg, dirmsgsv);
3022 sv_catpvn(msg, ")", 1);
3023 SvREFCNT_dec(dirmsgsv);
3024 msgstr = SvPV_nolen(msg);
3026 DIE(aTHX_ "Can't locate %s", msgstr);
3032 SETERRNO(0, SS$_NORMAL);
3034 /* Assume success here to prevent recursive requirement. */
3035 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3036 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3040 lex_start(sv_2mortal(newSVpvn("",0)));
3041 SAVEGENERICSV(PL_rsfp_filters);
3042 PL_rsfp_filters = Nullav;
3047 SAVESPTR(PL_compiling.cop_warnings);
3048 if (PL_dowarn & G_WARN_ALL_ON)
3049 PL_compiling.cop_warnings = WARN_ALL ;
3050 else if (PL_dowarn & G_WARN_ALL_OFF)
3051 PL_compiling.cop_warnings = WARN_NONE ;
3053 PL_compiling.cop_warnings = WARN_STD ;
3055 if (filter_sub || filter_child_proc) {
3056 SV *datasv = filter_add(run_user_filter, Nullsv);
3057 IoLINES(datasv) = filter_has_file;
3058 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3059 IoTOP_GV(datasv) = (GV *)filter_state;
3060 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3063 /* switch to eval mode */
3064 push_return(PL_op->op_next);
3065 PUSHBLOCK(cx, CXt_EVAL, SP);
3066 PUSHEVAL(cx, name, Nullgv);
3068 SAVECOPLINE(&PL_compiling);
3069 CopLINE_set(&PL_compiling, 0);
3073 MUTEX_LOCK(&PL_eval_mutex);
3074 if (PL_eval_owner && PL_eval_owner != thr)
3075 while (PL_eval_owner)
3076 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3077 PL_eval_owner = thr;
3078 MUTEX_UNLOCK(&PL_eval_mutex);
3079 #endif /* USE_THREADS */
3080 return DOCATCH(doeval(G_SCALAR, NULL));
3085 return pp_require();
3091 register PERL_CONTEXT *cx;
3093 I32 gimme = GIMME_V, was = PL_sub_generation;
3094 char tmpbuf[TYPE_DIGITS(long) + 12];
3099 if (!SvPV(sv,len) || !len)
3101 TAINT_PROPER("eval");
3107 /* switch to eval mode */
3109 SAVECOPFILE(&PL_compiling);
3110 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3111 CopFILE_set(&PL_compiling, tmpbuf+2);
3112 CopLINE_set(&PL_compiling, 1);
3113 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3114 deleting the eval's FILEGV from the stash before gv_check() runs
3115 (i.e. before run-time proper). To work around the coredump that
3116 ensues, we always turn GvMULTI_on for any globals that were
3117 introduced within evals. See force_ident(). GSAR 96-10-12 */
3118 safestr = savepv(tmpbuf);
3119 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3121 PL_hints = PL_op->op_targ;
3122 SAVESPTR(PL_compiling.cop_warnings);
3123 if (!specialWARN(PL_compiling.cop_warnings)) {
3124 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3125 SAVEFREESV(PL_compiling.cop_warnings) ;
3128 push_return(PL_op->op_next);
3129 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3130 PUSHEVAL(cx, 0, Nullgv);
3132 /* prepare to compile string */
3134 if (PERLDB_LINE && PL_curstash != PL_debstash)
3135 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3138 MUTEX_LOCK(&PL_eval_mutex);
3139 if (PL_eval_owner && PL_eval_owner != thr)
3140 while (PL_eval_owner)
3141 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3142 PL_eval_owner = thr;
3143 MUTEX_UNLOCK(&PL_eval_mutex);
3144 #endif /* USE_THREADS */
3145 ret = doeval(gimme, NULL);
3146 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3147 && ret != PL_op->op_next) { /* Successive compilation. */
3148 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3150 return DOCATCH(ret);
3160 register PERL_CONTEXT *cx;
3162 U8 save_flags = PL_op -> op_flags;
3167 retop = pop_return();
3170 if (gimme == G_VOID)
3172 else if (gimme == G_SCALAR) {
3175 if (SvFLAGS(TOPs) & SVs_TEMP)
3178 *MARK = sv_mortalcopy(TOPs);
3182 *MARK = &PL_sv_undef;
3187 /* in case LEAVE wipes old return values */
3188 for (mark = newsp + 1; mark <= SP; mark++) {
3189 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3190 *mark = sv_mortalcopy(*mark);
3191 TAINT_NOT; /* Each item is independent */
3195 PL_curpm = newpm; /* Don't pop $1 et al till now */
3197 if (AvFILLp(PL_comppad_name) >= 0)
3201 assert(CvDEPTH(PL_compcv) == 1);
3203 CvDEPTH(PL_compcv) = 0;
3206 if (optype == OP_REQUIRE &&
3207 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3209 /* Unassume the success we assumed earlier. */
3210 char *name = cx->blk_eval.old_name;
3211 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3212 retop = Perl_die(aTHX_ "%s did not return a true value", name);
3213 /* die_where() did LEAVE, or we won't be here */
3217 if (!(save_flags & OPf_SPECIAL))
3227 register PERL_CONTEXT *cx;
3228 I32 gimme = GIMME_V;
3233 push_return(cLOGOP->op_other->op_next);
3234 PUSHBLOCK(cx, CXt_EVAL, SP);
3236 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3238 PL_in_eval = EVAL_INEVAL;
3241 return DOCATCH(PL_op->op_next);
3251 register PERL_CONTEXT *cx;
3259 if (gimme == G_VOID)
3261 else if (gimme == G_SCALAR) {
3264 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3267 *MARK = sv_mortalcopy(TOPs);
3271 *MARK = &PL_sv_undef;
3276 /* in case LEAVE wipes old return values */
3277 for (mark = newsp + 1; mark <= SP; mark++) {
3278 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3279 *mark = sv_mortalcopy(*mark);
3280 TAINT_NOT; /* Each item is independent */
3284 PL_curpm = newpm; /* Don't pop $1 et al till now */
3292 S_doparseform(pTHX_ SV *sv)
3295 register char *s = SvPV_force(sv, len);
3296 register char *send = s + len;
3297 register char *base;
3298 register I32 skipspaces = 0;
3301 bool postspace = FALSE;
3309 Perl_croak(aTHX_ "Null picture in formline");
3311 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3316 *fpc++ = FF_LINEMARK;
3317 noblank = repeat = FALSE;
3335 case ' ': case '\t':
3346 *fpc++ = FF_LITERAL;
3354 *fpc++ = skipspaces;
3358 *fpc++ = FF_NEWLINE;
3362 arg = fpc - linepc + 1;
3369 *fpc++ = FF_LINEMARK;
3370 noblank = repeat = FALSE;
3379 ischop = s[-1] == '^';
3385 arg = (s - base) - 1;
3387 *fpc++ = FF_LITERAL;
3396 *fpc++ = FF_LINEGLOB;
3398 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3399 arg = ischop ? 512 : 0;
3409 arg |= 256 + (s - f);
3411 *fpc++ = s - base; /* fieldsize for FETCH */
3412 *fpc++ = FF_DECIMAL;
3417 bool ismore = FALSE;
3420 while (*++s == '>') ;
3421 prespace = FF_SPACE;
3423 else if (*s == '|') {
3424 while (*++s == '|') ;
3425 prespace = FF_HALFSPACE;
3430 while (*++s == '<') ;
3433 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3437 *fpc++ = s - base; /* fieldsize for FETCH */
3439 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3457 { /* need to jump to the next word */
3459 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3460 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3461 s = SvPVX(sv) + SvCUR(sv) + z;
3463 Copy(fops, s, arg, U16);
3465 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3470 * The rest of this file was derived from source code contributed
3473 * NOTE: this code was derived from Tom Horsley's qsort replacement
3474 * and should not be confused with the original code.
3477 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3479 Permission granted to distribute under the same terms as perl which are
3482 This program is free software; you can redistribute it and/or modify
3483 it under the terms of either:
3485 a) the GNU General Public License as published by the Free
3486 Software Foundation; either version 1, or (at your option) any
3489 b) the "Artistic License" which comes with this Kit.
3491 Details on the perl license can be found in the perl source code which
3492 may be located via the www.perl.com web page.
3494 This is the most wonderfulest possible qsort I can come up with (and
3495 still be mostly portable) My (limited) tests indicate it consistently
3496 does about 20% fewer calls to compare than does the qsort in the Visual
3497 C++ library, other vendors may vary.
3499 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3500 others I invented myself (or more likely re-invented since they seemed
3501 pretty obvious once I watched the algorithm operate for a while).
3503 Most of this code was written while watching the Marlins sweep the Giants
3504 in the 1997 National League Playoffs - no Braves fans allowed to use this
3505 code (just kidding :-).
3507 I realize that if I wanted to be true to the perl tradition, the only
3508 comment in this file would be something like:
3510 ...they shuffled back towards the rear of the line. 'No, not at the
3511 rear!' the slave-driver shouted. 'Three files up. And stay there...
3513 However, I really needed to violate that tradition just so I could keep
3514 track of what happens myself, not to mention some poor fool trying to
3515 understand this years from now :-).
3518 /* ********************************************************** Configuration */
3520 #ifndef QSORT_ORDER_GUESS
3521 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3524 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3525 future processing - a good max upper bound is log base 2 of memory size
3526 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3527 safely be smaller than that since the program is taking up some space and
3528 most operating systems only let you grab some subset of contiguous
3529 memory (not to mention that you are normally sorting data larger than
3530 1 byte element size :-).
3532 #ifndef QSORT_MAX_STACK
3533 #define QSORT_MAX_STACK 32
3536 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3537 Anything bigger and we use qsort. If you make this too small, the qsort
3538 will probably break (or become less efficient), because it doesn't expect
3539 the middle element of a partition to be the same as the right or left -
3540 you have been warned).
3542 #ifndef QSORT_BREAK_EVEN
3543 #define QSORT_BREAK_EVEN 6
3546 /* ************************************************************* Data Types */
3548 /* hold left and right index values of a partition waiting to be sorted (the
3549 partition includes both left and right - right is NOT one past the end or
3550 anything like that).
3552 struct partition_stack_entry {
3555 #ifdef QSORT_ORDER_GUESS
3556 int qsort_break_even;
3560 /* ******************************************************* Shorthand Macros */
3562 /* Note that these macros will be used from inside the qsort function where
3563 we happen to know that the variable 'elt_size' contains the size of an
3564 array element and the variable 'temp' points to enough space to hold a
3565 temp element and the variable 'array' points to the array being sorted
3566 and 'compare' is the pointer to the compare routine.
3568 Also note that there are very many highly architecture specific ways
3569 these might be sped up, but this is simply the most generally portable
3570 code I could think of.
3573 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3575 #define qsort_cmp(elt1, elt2) \
3576 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3578 #ifdef QSORT_ORDER_GUESS
3579 #define QSORT_NOTICE_SWAP swapped++;
3581 #define QSORT_NOTICE_SWAP
3584 /* swaps contents of array elements elt1, elt2.
3586 #define qsort_swap(elt1, elt2) \
3589 temp = array[elt1]; \
3590 array[elt1] = array[elt2]; \
3591 array[elt2] = temp; \
3594 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3595 elt3 and elt3 gets elt1.
3597 #define qsort_rotate(elt1, elt2, elt3) \
3600 temp = array[elt1]; \
3601 array[elt1] = array[elt2]; \
3602 array[elt2] = array[elt3]; \
3603 array[elt3] = temp; \
3606 /* ************************************************************ Debug stuff */
3613 return; /* good place to set a breakpoint */
3616 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3619 doqsort_all_asserts(
3623 int (*compare)(const void * elt1, const void * elt2),
3624 int pc_left, int pc_right, int u_left, int u_right)
3628 qsort_assert(pc_left <= pc_right);
3629 qsort_assert(u_right < pc_left);
3630 qsort_assert(pc_right < u_left);
3631 for (i = u_right + 1; i < pc_left; ++i) {
3632 qsort_assert(qsort_cmp(i, pc_left) < 0);
3634 for (i = pc_left; i < pc_right; ++i) {
3635 qsort_assert(qsort_cmp(i, pc_right) == 0);
3637 for (i = pc_right + 1; i < u_left; ++i) {
3638 qsort_assert(qsort_cmp(pc_right, i) < 0);
3642 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3643 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3644 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3648 #define qsort_assert(t) ((void)0)
3650 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3654 /* ****************************************************************** qsort */
3657 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3661 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3662 int next_stack_entry = 0;
3666 #ifdef QSORT_ORDER_GUESS
3667 int qsort_break_even;
3671 /* Make sure we actually have work to do.
3673 if (num_elts <= 1) {
3677 /* Setup the initial partition definition and fall into the sorting loop
3680 part_right = (int)(num_elts - 1);
3681 #ifdef QSORT_ORDER_GUESS
3682 qsort_break_even = QSORT_BREAK_EVEN;
3684 #define qsort_break_even QSORT_BREAK_EVEN
3687 if ((part_right - part_left) >= qsort_break_even) {
3688 /* OK, this is gonna get hairy, so lets try to document all the
3689 concepts and abbreviations and variables and what they keep
3692 pc: pivot chunk - the set of array elements we accumulate in the
3693 middle of the partition, all equal in value to the original
3694 pivot element selected. The pc is defined by:
3696 pc_left - the leftmost array index of the pc
3697 pc_right - the rightmost array index of the pc
3699 we start with pc_left == pc_right and only one element
3700 in the pivot chunk (but it can grow during the scan).
3702 u: uncompared elements - the set of elements in the partition
3703 we have not yet compared to the pivot value. There are two
3704 uncompared sets during the scan - one to the left of the pc
3705 and one to the right.
3707 u_right - the rightmost index of the left side's uncompared set
3708 u_left - the leftmost index of the right side's uncompared set
3710 The leftmost index of the left sides's uncompared set
3711 doesn't need its own variable because it is always defined
3712 by the leftmost edge of the whole partition (part_left). The
3713 same goes for the rightmost edge of the right partition
3716 We know there are no uncompared elements on the left once we
3717 get u_right < part_left and no uncompared elements on the
3718 right once u_left > part_right. When both these conditions
3719 are met, we have completed the scan of the partition.
3721 Any elements which are between the pivot chunk and the
3722 uncompared elements should be less than the pivot value on
3723 the left side and greater than the pivot value on the right
3724 side (in fact, the goal of the whole algorithm is to arrange
3725 for that to be true and make the groups of less-than and
3726 greater-then elements into new partitions to sort again).
3728 As you marvel at the complexity of the code and wonder why it
3729 has to be so confusing. Consider some of the things this level
3730 of confusion brings:
3732 Once I do a compare, I squeeze every ounce of juice out of it. I
3733 never do compare calls I don't have to do, and I certainly never
3736 I also never swap any elements unless I can prove there is a
3737 good reason. Many sort algorithms will swap a known value with
3738 an uncompared value just to get things in the right place (or
3739 avoid complexity :-), but that uncompared value, once it gets
3740 compared, may then have to be swapped again. A lot of the
3741 complexity of this code is due to the fact that it never swaps
3742 anything except compared values, and it only swaps them when the
3743 compare shows they are out of position.
3745 int pc_left, pc_right;
3746 int u_right, u_left;
3750 pc_left = ((part_left + part_right) / 2);
3752 u_right = pc_left - 1;
3753 u_left = pc_right + 1;
3755 /* Qsort works best when the pivot value is also the median value
3756 in the partition (unfortunately you can't find the median value
3757 without first sorting :-), so to give the algorithm a helping
3758 hand, we pick 3 elements and sort them and use the median value
3759 of that tiny set as the pivot value.
3761 Some versions of qsort like to use the left middle and right as
3762 the 3 elements to sort so they can insure the ends of the
3763 partition will contain values which will stop the scan in the
3764 compare loop, but when you have to call an arbitrarily complex
3765 routine to do a compare, its really better to just keep track of
3766 array index values to know when you hit the edge of the
3767 partition and avoid the extra compare. An even better reason to
3768 avoid using a compare call is the fact that you can drop off the
3769 edge of the array if someone foolishly provides you with an
3770 unstable compare function that doesn't always provide consistent
3773 So, since it is simpler for us to compare the three adjacent
3774 elements in the middle of the partition, those are the ones we
3775 pick here (conveniently pointed at by u_right, pc_left, and
3776 u_left). The values of the left, center, and right elements
3777 are refered to as l c and r in the following comments.
3780 #ifdef QSORT_ORDER_GUESS
3783 s = qsort_cmp(u_right, pc_left);
3786 s = qsort_cmp(pc_left, u_left);
3787 /* if l < c, c < r - already in order - nothing to do */
3789 /* l < c, c == r - already in order, pc grows */
3791 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3793 /* l < c, c > r - need to know more */
3794 s = qsort_cmp(u_right, u_left);
3796 /* l < c, c > r, l < r - swap c & r to get ordered */
3797 qsort_swap(pc_left, u_left);
3798 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3799 } else if (s == 0) {
3800 /* l < c, c > r, l == r - swap c&r, grow pc */
3801 qsort_swap(pc_left, u_left);
3803 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3805 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3806 qsort_rotate(pc_left, u_right, u_left);
3807 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3810 } else if (s == 0) {
3812 s = qsort_cmp(pc_left, u_left);
3814 /* l == c, c < r - already in order, grow pc */
3816 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3817 } else if (s == 0) {
3818 /* l == c, c == r - already in order, grow pc both ways */
3821 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3823 /* l == c, c > r - swap l & r, grow pc */
3824 qsort_swap(u_right, u_left);
3826 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3830 s = qsort_cmp(pc_left, u_left);
3832 /* l > c, c < r - need to know more */
3833 s = qsort_cmp(u_right, u_left);
3835 /* l > c, c < r, l < r - swap l & c to get ordered */
3836 qsort_swap(u_right, pc_left);
3837 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3838 } else if (s == 0) {
3839 /* l > c, c < r, l == r - swap l & c, grow pc */
3840 qsort_swap(u_right, pc_left);
3842 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3844 /* l > c, c < r, l > r - rotate lcr into crl to order */
3845 qsort_rotate(u_right, pc_left, u_left);
3846 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3848 } else if (s == 0) {
3849 /* l > c, c == r - swap ends, grow pc */
3850 qsort_swap(u_right, u_left);
3852 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3854 /* l > c, c > r - swap ends to get in order */
3855 qsort_swap(u_right, u_left);
3856 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3859 /* We now know the 3 middle elements have been compared and
3860 arranged in the desired order, so we can shrink the uncompared
3865 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3867 /* The above massive nested if was the simple part :-). We now have
3868 the middle 3 elements ordered and we need to scan through the
3869 uncompared sets on either side, swapping elements that are on
3870 the wrong side or simply shuffling equal elements around to get
3871 all equal elements into the pivot chunk.
3875 int still_work_on_left;
3876 int still_work_on_right;
3878 /* Scan the uncompared values on the left. If I find a value
3879 equal to the pivot value, move it over so it is adjacent to
3880 the pivot chunk and expand the pivot chunk. If I find a value
3881 less than the pivot value, then just leave it - its already
3882 on the correct side of the partition. If I find a greater
3883 value, then stop the scan.
3885 while (still_work_on_left = (u_right >= part_left)) {
3886 s = qsort_cmp(u_right, pc_left);
3889 } else if (s == 0) {
3891 if (pc_left != u_right) {
3892 qsort_swap(u_right, pc_left);
3898 qsort_assert(u_right < pc_left);
3899 qsort_assert(pc_left <= pc_right);
3900 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3901 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3904 /* Do a mirror image scan of uncompared values on the right
3906 while (still_work_on_right = (u_left <= part_right)) {
3907 s = qsort_cmp(pc_right, u_left);
3910 } else if (s == 0) {
3912 if (pc_right != u_left) {
3913 qsort_swap(pc_right, u_left);
3919 qsort_assert(u_left > pc_right);
3920 qsort_assert(pc_left <= pc_right);
3921 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3922 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3925 if (still_work_on_left) {
3926 /* I know I have a value on the left side which needs to be
3927 on the right side, but I need to know more to decide
3928 exactly the best thing to do with it.
3930 if (still_work_on_right) {
3931 /* I know I have values on both side which are out of
3932 position. This is a big win because I kill two birds
3933 with one swap (so to speak). I can advance the
3934 uncompared pointers on both sides after swapping both
3935 of them into the right place.
3937 qsort_swap(u_right, u_left);
3940 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3942 /* I have an out of position value on the left, but the
3943 right is fully scanned, so I "slide" the pivot chunk
3944 and any less-than values left one to make room for the
3945 greater value over on the right. If the out of position
3946 value is immediately adjacent to the pivot chunk (there
3947 are no less-than values), I can do that with a swap,
3948 otherwise, I have to rotate one of the less than values
3949 into the former position of the out of position value
3950 and the right end of the pivot chunk into the left end
3954 if (pc_left == u_right) {
3955 qsort_swap(u_right, pc_right);
3956 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3958 qsort_rotate(u_right, pc_left, pc_right);
3959 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3964 } else if (still_work_on_right) {
3965 /* Mirror image of complex case above: I have an out of
3966 position value on the right, but the left is fully
3967 scanned, so I need to shuffle things around to make room
3968 for the right value on the left.
3971 if (pc_right == u_left) {
3972 qsort_swap(u_left, pc_left);
3973 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3975 qsort_rotate(pc_right, pc_left, u_left);
3976 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3981 /* No more scanning required on either side of partition,
3982 break out of loop and figure out next set of partitions
3988 /* The elements in the pivot chunk are now in the right place. They
3989 will never move or be compared again. All I have to do is decide
3990 what to do with the stuff to the left and right of the pivot
3993 Notes on the QSORT_ORDER_GUESS ifdef code:
3995 1. If I just built these partitions without swapping any (or
3996 very many) elements, there is a chance that the elements are
3997 already ordered properly (being properly ordered will
3998 certainly result in no swapping, but the converse can't be
4001 2. A (properly written) insertion sort will run faster on
4002 already ordered data than qsort will.
4004 3. Perhaps there is some way to make a good guess about
4005 switching to an insertion sort earlier than partition size 6
4006 (for instance - we could save the partition size on the stack
4007 and increase the size each time we find we didn't swap, thus
4008 switching to insertion sort earlier for partitions with a
4009 history of not swapping).
4011 4. Naturally, if I just switch right away, it will make
4012 artificial benchmarks with pure ascending (or descending)
4013 data look really good, but is that a good reason in general?
4017 #ifdef QSORT_ORDER_GUESS
4019 #if QSORT_ORDER_GUESS == 1
4020 qsort_break_even = (part_right - part_left) + 1;
4022 #if QSORT_ORDER_GUESS == 2
4023 qsort_break_even *= 2;
4025 #if QSORT_ORDER_GUESS == 3
4026 int prev_break = qsort_break_even;
4027 qsort_break_even *= qsort_break_even;
4028 if (qsort_break_even < prev_break) {
4029 qsort_break_even = (part_right - part_left) + 1;
4033 qsort_break_even = QSORT_BREAK_EVEN;
4037 if (part_left < pc_left) {
4038 /* There are elements on the left which need more processing.
4039 Check the right as well before deciding what to do.
4041 if (pc_right < part_right) {
4042 /* We have two partitions to be sorted. Stack the biggest one
4043 and process the smallest one on the next iteration. This
4044 minimizes the stack height by insuring that any additional
4045 stack entries must come from the smallest partition which
4046 (because it is smallest) will have the fewest
4047 opportunities to generate additional stack entries.
4049 if ((part_right - pc_right) > (pc_left - part_left)) {
4050 /* stack the right partition, process the left */
4051 partition_stack[next_stack_entry].left = pc_right + 1;
4052 partition_stack[next_stack_entry].right = part_right;
4053 #ifdef QSORT_ORDER_GUESS
4054 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4056 part_right = pc_left - 1;
4058 /* stack the left partition, process the right */
4059 partition_stack[next_stack_entry].left = part_left;
4060 partition_stack[next_stack_entry].right = pc_left - 1;
4061 #ifdef QSORT_ORDER_GUESS
4062 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4064 part_left = pc_right + 1;
4066 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4069 /* The elements on the left are the only remaining elements
4070 that need sorting, arrange for them to be processed as the
4073 part_right = pc_left - 1;
4075 } else if (pc_right < part_right) {
4076 /* There is only one chunk on the right to be sorted, make it
4077 the new partition and loop back around.
4079 part_left = pc_right + 1;
4081 /* This whole partition wound up in the pivot chunk, so
4082 we need to get a new partition off the stack.
4084 if (next_stack_entry == 0) {
4085 /* the stack is empty - we are done */
4089 part_left = partition_stack[next_stack_entry].left;
4090 part_right = partition_stack[next_stack_entry].right;
4091 #ifdef QSORT_ORDER_GUESS
4092 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4096 /* This partition is too small to fool with qsort complexity, just
4097 do an ordinary insertion sort to minimize overhead.
4100 /* Assume 1st element is in right place already, and start checking
4101 at 2nd element to see where it should be inserted.
4103 for (i = part_left + 1; i <= part_right; ++i) {
4105 /* Scan (backwards - just in case 'i' is already in right place)
4106 through the elements already sorted to see if the ith element
4107 belongs ahead of one of them.
4109 for (j = i - 1; j >= part_left; --j) {
4110 if (qsort_cmp(i, j) >= 0) {
4111 /* i belongs right after j
4118 /* Looks like we really need to move some things
4122 for (k = i - 1; k >= j; --k)
4123 array[k + 1] = array[k];
4128 /* That partition is now sorted, grab the next one, or get out
4129 of the loop if there aren't any more.
4132 if (next_stack_entry == 0) {
4133 /* the stack is empty - we are done */
4137 part_left = partition_stack[next_stack_entry].left;
4138 part_right = partition_stack[next_stack_entry].right;
4139 #ifdef QSORT_ORDER_GUESS
4140 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4145 /* Believe it or not, the array is sorted at this point! */
4157 sortcv(pTHXo_ SV *a, SV *b)
4160 I32 oldsaveix = PL_savestack_ix;
4161 I32 oldscopeix = PL_scopestack_ix;
4163 GvSV(PL_firstgv) = a;
4164 GvSV(PL_secondgv) = b;
4165 PL_stack_sp = PL_stack_base;
4168 if (PL_stack_sp != PL_stack_base + 1)
4169 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4170 if (!SvNIOKp(*PL_stack_sp))
4171 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4172 result = SvIV(*PL_stack_sp);
4173 while (PL_scopestack_ix > oldscopeix) {
4176 leave_scope(oldsaveix);
4181 sortcv_stacked(pTHXo_ SV *a, SV *b)
4184 I32 oldsaveix = PL_savestack_ix;
4185 I32 oldscopeix = PL_scopestack_ix;
4190 av = (AV*)PL_curpad[0];
4192 av = GvAV(PL_defgv);
4195 if (AvMAX(av) < 1) {
4196 SV** ary = AvALLOC(av);
4197 if (AvARRAY(av) != ary) {
4198 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4199 SvPVX(av) = (char*)ary;
4201 if (AvMAX(av) < 1) {
4204 SvPVX(av) = (char*)ary;
4211 PL_stack_sp = PL_stack_base;
4214 if (PL_stack_sp != PL_stack_base + 1)
4215 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4216 if (!SvNIOKp(*PL_stack_sp))
4217 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4218 result = SvIV(*PL_stack_sp);
4219 while (PL_scopestack_ix > oldscopeix) {
4222 leave_scope(oldsaveix);
4227 sortcv_xsub(pTHXo_ SV *a, SV *b)
4230 I32 oldsaveix = PL_savestack_ix;
4231 I32 oldscopeix = PL_scopestack_ix;
4233 CV *cv=(CV*)PL_sortcop;
4241 (void)(*CvXSUB(cv))(aTHXo_ cv);
4242 if (PL_stack_sp != PL_stack_base + 1)
4243 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4244 if (!SvNIOKp(*PL_stack_sp))
4245 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4246 result = SvIV(*PL_stack_sp);
4247 while (PL_scopestack_ix > oldscopeix) {
4250 leave_scope(oldsaveix);
4256 sv_ncmp(pTHXo_ SV *a, SV *b)
4260 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4264 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4268 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4270 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4272 if (PL_amagic_generation) { \
4273 if (SvAMAGIC(left)||SvAMAGIC(right))\
4274 *svp = amagic_call(left, \
4282 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4285 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4290 I32 i = SvIVX(tmpsv);
4300 return sv_ncmp(aTHXo_ a, b);
4304 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4307 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4312 I32 i = SvIVX(tmpsv);
4322 return sv_i_ncmp(aTHXo_ a, b);
4326 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4329 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4334 I32 i = SvIVX(tmpsv);
4344 return sv_cmp(str1, str2);
4348 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4351 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4356 I32 i = SvIVX(tmpsv);
4366 return sv_cmp_locale(str1, str2);
4370 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4372 SV *datasv = FILTER_DATA(idx);
4373 int filter_has_file = IoLINES(datasv);
4374 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4375 SV *filter_state = (SV *)IoTOP_GV(datasv);
4376 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4379 /* I was having segfault trouble under Linux 2.2.5 after a
4380 parse error occured. (Had to hack around it with a test
4381 for PL_error_count == 0.) Solaris doesn't segfault --
4382 not sure where the trouble is yet. XXX */
4384 if (filter_has_file) {
4385 len = FILTER_READ(idx+1, buf_sv, maxlen);
4388 if (filter_sub && len >= 0) {
4399 PUSHs(sv_2mortal(newSViv(maxlen)));
4401 PUSHs(filter_state);
4404 count = call_sv(filter_sub, G_SCALAR);
4420 IoLINES(datasv) = 0;
4421 if (filter_child_proc) {
4422 SvREFCNT_dec(filter_child_proc);
4423 IoFMT_GV(datasv) = Nullgv;
4426 SvREFCNT_dec(filter_state);
4427 IoTOP_GV(datasv) = Nullgv;
4430 SvREFCNT_dec(filter_sub);
4431 IoBOTTOM_GV(datasv) = Nullgv;
4433 filter_del(run_user_filter);
4442 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4444 return sv_cmp_locale(str1, str2);
4448 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4450 return sv_cmp(str1, str2);
4453 #endif /* PERL_OBJECT */