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 SvNIOKp(right) || !SvPOKp(right) ||
1001 (looks_like_number(left) && *SvPVX(left) != '0' &&
1002 looks_like_number(right) && *SvPVX(right) != '0'))
1004 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1005 DIE(aTHX_ "Range iterator outside integer range");
1016 sv = sv_2mortal(newSViv(i++));
1021 SV *final = sv_mortalcopy(right);
1023 char *tmps = SvPV(final, len);
1025 sv = sv_mortalcopy(left);
1027 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1029 if (strEQ(SvPVX(sv),tmps))
1031 sv = sv_2mortal(newSVsv(sv));
1038 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1040 if ((PL_op->op_private & OPpFLIP_LINENUM)
1041 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1043 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1044 sv_catpv(targ, "E0");
1055 S_dopoptolabel(pTHX_ char *label)
1059 register PERL_CONTEXT *cx;
1061 for (i = cxstack_ix; i >= 0; i--) {
1063 switch (CxTYPE(cx)) {
1065 if (ckWARN(WARN_UNSAFE))
1066 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1067 PL_op_name[PL_op->op_type]);
1070 if (ckWARN(WARN_UNSAFE))
1071 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1072 PL_op_name[PL_op->op_type]);
1075 if (ckWARN(WARN_UNSAFE))
1076 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1077 PL_op_name[PL_op->op_type]);
1080 if (ckWARN(WARN_UNSAFE))
1081 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1082 PL_op_name[PL_op->op_type]);
1085 if (ckWARN(WARN_UNSAFE))
1086 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1087 PL_op_name[PL_op->op_type]);
1090 if (!cx->blk_loop.label ||
1091 strNE(label, cx->blk_loop.label) ) {
1092 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1093 (long)i, cx->blk_loop.label));
1096 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1104 Perl_dowantarray(pTHX)
1106 I32 gimme = block_gimme();
1107 return (gimme == G_VOID) ? G_SCALAR : gimme;
1111 Perl_block_gimme(pTHX)
1116 cxix = dopoptosub(cxstack_ix);
1120 switch (cxstack[cxix].blk_gimme) {
1128 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1135 S_dopoptosub(pTHX_ I32 startingblock)
1138 return dopoptosub_at(cxstack, startingblock);
1142 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1146 register PERL_CONTEXT *cx;
1147 for (i = startingblock; i >= 0; i--) {
1149 switch (CxTYPE(cx)) {
1155 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1163 S_dopoptoeval(pTHX_ I32 startingblock)
1167 register PERL_CONTEXT *cx;
1168 for (i = startingblock; i >= 0; i--) {
1170 switch (CxTYPE(cx)) {
1174 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1182 S_dopoptoloop(pTHX_ I32 startingblock)
1186 register PERL_CONTEXT *cx;
1187 for (i = startingblock; i >= 0; i--) {
1189 switch (CxTYPE(cx)) {
1191 if (ckWARN(WARN_UNSAFE))
1192 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1193 PL_op_name[PL_op->op_type]);
1196 if (ckWARN(WARN_UNSAFE))
1197 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1198 PL_op_name[PL_op->op_type]);
1201 if (ckWARN(WARN_UNSAFE))
1202 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1203 PL_op_name[PL_op->op_type]);
1206 if (ckWARN(WARN_UNSAFE))
1207 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1208 PL_op_name[PL_op->op_type]);
1211 if (ckWARN(WARN_UNSAFE))
1212 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1213 PL_op_name[PL_op->op_type]);
1216 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1224 Perl_dounwind(pTHX_ I32 cxix)
1227 register PERL_CONTEXT *cx;
1231 while (cxstack_ix > cxix) {
1233 cx = &cxstack[cxstack_ix];
1234 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1235 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1236 /* Note: we don't need to restore the base context info till the end. */
1237 switch (CxTYPE(cx)) {
1240 continue; /* not break */
1262 * Closures mentioned at top level of eval cannot be referenced
1263 * again, and their presence indirectly causes a memory leak.
1264 * (Note that the fact that compcv and friends are still set here
1265 * is, AFAIK, an accident.) --Chip
1267 * XXX need to get comppad et al from eval's cv rather than
1268 * relying on the incidental global values.
1271 S_free_closures(pTHX)
1274 SV **svp = AvARRAY(PL_comppad_name);
1276 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1278 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1280 svp[ix] = &PL_sv_undef;
1284 SvREFCNT_dec(CvOUTSIDE(sv));
1285 CvOUTSIDE(sv) = Nullcv;
1298 Perl_qerror(pTHX_ SV *err)
1301 sv_catsv(ERRSV, err);
1303 sv_catsv(PL_errors, err);
1305 Perl_warn(aTHX_ "%"SVf, err);
1310 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1316 register PERL_CONTEXT *cx;
1321 if (PL_in_eval & EVAL_KEEPERR) {
1322 static char prefix[] = "\t(in cleanup) ";
1327 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1330 if (*e != *message || strNE(e,message))
1334 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1335 sv_catpvn(err, prefix, sizeof(prefix)-1);
1336 sv_catpvn(err, message, msglen);
1337 if (ckWARN(WARN_UNSAFE)) {
1338 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1339 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1344 sv_setpvn(ERRSV, message, msglen);
1347 message = SvPVx(ERRSV, msglen);
1349 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1350 && PL_curstackinfo->si_prev)
1359 if (cxix < cxstack_ix)
1362 POPBLOCK(cx,PL_curpm);
1363 if (CxTYPE(cx) != CXt_EVAL) {
1364 PerlIO_write(Perl_error_log, "panic: die ", 11);
1365 PerlIO_write(Perl_error_log, message, msglen);
1370 if (gimme == G_SCALAR)
1371 *++newsp = &PL_sv_undef;
1372 PL_stack_sp = newsp;
1376 if (optype == OP_REQUIRE) {
1377 char* msg = SvPVx(ERRSV, n_a);
1378 DIE(aTHX_ "%sCompilation failed in require",
1379 *msg ? msg : "Unknown error\n");
1381 return pop_return();
1385 message = SvPVx(ERRSV, msglen);
1388 /* SFIO can really mess with your errno */
1391 PerlIO *serr = Perl_error_log;
1393 PerlIO_write(serr, message, msglen);
1394 (void)PerlIO_flush(serr);
1407 if (SvTRUE(left) != SvTRUE(right))
1419 RETURNOP(cLOGOP->op_other);
1428 RETURNOP(cLOGOP->op_other);
1434 register I32 cxix = dopoptosub(cxstack_ix);
1435 register PERL_CONTEXT *cx;
1436 register PERL_CONTEXT *ccstack = cxstack;
1437 PERL_SI *top_si = PL_curstackinfo;
1448 /* we may be in a higher stacklevel, so dig down deeper */
1449 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1450 top_si = top_si->si_prev;
1451 ccstack = top_si->si_cxstack;
1452 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1455 if (GIMME != G_ARRAY)
1459 if (PL_DBsub && cxix >= 0 &&
1460 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1464 cxix = dopoptosub_at(ccstack, cxix - 1);
1467 cx = &ccstack[cxix];
1468 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1469 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1470 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1471 field below is defined for any cx. */
1472 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1473 cx = &ccstack[dbcxix];
1476 stashname = CopSTASHPV(cx->blk_oldcop);
1477 if (GIMME != G_ARRAY) {
1479 PUSHs(&PL_sv_undef);
1482 sv_setpv(TARG, stashname);
1489 PUSHs(&PL_sv_undef);
1491 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1492 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1493 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1496 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1497 /* So is ccstack[dbcxix]. */
1499 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1500 PUSHs(sv_2mortal(sv));
1501 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1504 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1505 PUSHs(sv_2mortal(newSViv(0)));
1507 gimme = (I32)cx->blk_gimme;
1508 if (gimme == G_VOID)
1509 PUSHs(&PL_sv_undef);
1511 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1512 if (CxTYPE(cx) == CXt_EVAL) {
1513 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1514 PUSHs(cx->blk_eval.cur_text);
1517 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1518 /* Require, put the name. */
1519 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1524 PUSHs(&PL_sv_undef);
1525 PUSHs(&PL_sv_undef);
1527 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1528 && CopSTASH_eq(PL_curcop, PL_debstash))
1530 AV *ary = cx->blk_sub.argarray;
1531 int off = AvARRAY(ary) - AvALLOC(ary);
1535 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1538 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1541 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1542 av_extend(PL_dbargs, AvFILLp(ary) + off);
1543 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1544 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1546 /* XXX only hints propagated via op_private are currently
1547 * visible (others are not easily accessible, since they
1548 * use the global PL_hints) */
1549 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1550 HINT_PRIVATE_MASK)));
1564 sv_reset(tmps, CopSTASH(PL_curcop));
1576 PL_curcop = (COP*)PL_op;
1577 TAINT_NOT; /* Each statement is presumed innocent */
1578 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1581 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1585 register PERL_CONTEXT *cx;
1586 I32 gimme = G_ARRAY;
1593 DIE(aTHX_ "No DB::DB routine defined");
1595 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1607 push_return(PL_op->op_next);
1608 PUSHBLOCK(cx, CXt_SUB, SP);
1611 (void)SvREFCNT_inc(cv);
1612 SAVEVPTR(PL_curpad);
1613 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1614 RETURNOP(CvSTART(cv));
1628 register PERL_CONTEXT *cx;
1629 I32 gimme = GIMME_V;
1631 U32 cxtype = CXt_LOOP;
1640 if (PL_op->op_flags & OPf_SPECIAL) {
1642 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1643 SAVEGENERICSV(*svp);
1647 #endif /* USE_THREADS */
1648 if (PL_op->op_targ) {
1649 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1652 iterdata = (void*)PL_op->op_targ;
1653 cxtype |= CXp_PADVAR;
1658 svp = &GvSV(gv); /* symbol table variable */
1659 SAVEGENERICSV(*svp);
1662 iterdata = (void*)gv;
1668 PUSHBLOCK(cx, cxtype, SP);
1670 PUSHLOOP(cx, iterdata, MARK);
1672 PUSHLOOP(cx, svp, MARK);
1674 if (PL_op->op_flags & OPf_STACKED) {
1675 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1676 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1678 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1679 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1680 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1681 looks_like_number((SV*)cx->blk_loop.iterary) &&
1682 *SvPVX(cx->blk_loop.iterary) != '0'))
1684 if (SvNV(sv) < IV_MIN ||
1685 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1686 DIE(aTHX_ "Range iterator outside integer range");
1687 cx->blk_loop.iterix = SvIV(sv);
1688 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1691 cx->blk_loop.iterlval = newSVsv(sv);
1695 cx->blk_loop.iterary = PL_curstack;
1696 AvFILLp(PL_curstack) = SP - PL_stack_base;
1697 cx->blk_loop.iterix = MARK - PL_stack_base;
1706 register PERL_CONTEXT *cx;
1707 I32 gimme = GIMME_V;
1713 PUSHBLOCK(cx, CXt_LOOP, SP);
1714 PUSHLOOP(cx, 0, SP);
1722 register PERL_CONTEXT *cx;
1730 newsp = PL_stack_base + cx->blk_loop.resetsp;
1733 if (gimme == G_VOID)
1735 else if (gimme == G_SCALAR) {
1737 *++newsp = sv_mortalcopy(*SP);
1739 *++newsp = &PL_sv_undef;
1743 *++newsp = sv_mortalcopy(*++mark);
1744 TAINT_NOT; /* Each item is independent */
1750 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1751 PL_curpm = newpm; /* ... and pop $1 et al */
1763 register PERL_CONTEXT *cx;
1764 bool popsub2 = FALSE;
1771 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1772 if (cxstack_ix == PL_sortcxix
1773 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1775 if (cxstack_ix > PL_sortcxix)
1776 dounwind(PL_sortcxix);
1777 AvARRAY(PL_curstack)[1] = *SP;
1778 PL_stack_sp = PL_stack_base + 1;
1783 cxix = dopoptosub(cxstack_ix);
1785 DIE(aTHX_ "Can't return outside a subroutine");
1786 if (cxix < cxstack_ix)
1790 switch (CxTYPE(cx)) {
1796 if (AvFILLp(PL_comppad_name) >= 0)
1799 if (optype == OP_REQUIRE &&
1800 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1802 /* Unassume the success we assumed earlier. */
1803 char *name = cx->blk_eval.old_name;
1804 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1805 DIE(aTHX_ "%s did not return a true value", name);
1812 DIE(aTHX_ "panic: return");
1816 if (gimme == G_SCALAR) {
1819 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1821 *++newsp = SvREFCNT_inc(*SP);
1826 *++newsp = sv_mortalcopy(*SP);
1829 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1831 *++newsp = sv_mortalcopy(*SP);
1833 *++newsp = &PL_sv_undef;
1835 else if (gimme == G_ARRAY) {
1836 while (++MARK <= SP) {
1837 *++newsp = (popsub2 && SvTEMP(*MARK))
1838 ? *MARK : sv_mortalcopy(*MARK);
1839 TAINT_NOT; /* Each item is independent */
1842 PL_stack_sp = newsp;
1844 /* Stack values are safe: */
1846 POPSUB(cx,sv); /* release CV and @_ ... */
1850 PL_curpm = newpm; /* ... and pop $1 et al */
1854 return pop_return();
1861 register PERL_CONTEXT *cx;
1871 if (PL_op->op_flags & OPf_SPECIAL) {
1872 cxix = dopoptoloop(cxstack_ix);
1874 DIE(aTHX_ "Can't \"last\" outside a loop block");
1877 cxix = dopoptolabel(cPVOP->op_pv);
1879 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1881 if (cxix < cxstack_ix)
1886 switch (CxTYPE(cx)) {
1889 newsp = PL_stack_base + cx->blk_loop.resetsp;
1890 nextop = cx->blk_loop.last_op->op_next;
1894 nextop = pop_return();
1898 nextop = pop_return();
1902 nextop = pop_return();
1905 DIE(aTHX_ "panic: last");
1909 if (gimme == G_SCALAR) {
1911 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1912 ? *SP : sv_mortalcopy(*SP);
1914 *++newsp = &PL_sv_undef;
1916 else if (gimme == G_ARRAY) {
1917 while (++MARK <= SP) {
1918 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1919 ? *MARK : sv_mortalcopy(*MARK);
1920 TAINT_NOT; /* Each item is independent */
1926 /* Stack values are safe: */
1929 POPLOOP(cx); /* release loop vars ... */
1933 POPSUB(cx,sv); /* release CV and @_ ... */
1936 PL_curpm = newpm; /* ... and pop $1 et al */
1946 register PERL_CONTEXT *cx;
1949 if (PL_op->op_flags & OPf_SPECIAL) {
1950 cxix = dopoptoloop(cxstack_ix);
1952 DIE(aTHX_ "Can't \"next\" outside a loop block");
1955 cxix = dopoptolabel(cPVOP->op_pv);
1957 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1959 if (cxix < cxstack_ix)
1962 cx = &cxstack[cxstack_ix];
1964 OP *nextop = cx->blk_loop.next_op;
1965 /* clean scope, but only if there's no continue block */
1966 if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) {
1968 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1969 LEAVE_SCOPE(oldsave);
1978 register PERL_CONTEXT *cx;
1981 if (PL_op->op_flags & OPf_SPECIAL) {
1982 cxix = dopoptoloop(cxstack_ix);
1984 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1987 cxix = dopoptolabel(cPVOP->op_pv);
1989 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1991 if (cxix < cxstack_ix)
1995 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1996 LEAVE_SCOPE(oldsave);
1997 return cx->blk_loop.redo_op;
2001 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2005 static char too_deep[] = "Target of goto is too deeply nested";
2008 Perl_croak(aTHX_ too_deep);
2009 if (o->op_type == OP_LEAVE ||
2010 o->op_type == OP_SCOPE ||
2011 o->op_type == OP_LEAVELOOP ||
2012 o->op_type == OP_LEAVETRY)
2014 *ops++ = cUNOPo->op_first;
2016 Perl_croak(aTHX_ too_deep);
2019 if (o->op_flags & OPf_KIDS) {
2021 /* First try all the kids at this level, since that's likeliest. */
2022 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2023 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2024 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2027 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2028 if (kid == PL_lastgotoprobe)
2030 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2032 (ops[-1]->op_type != OP_NEXTSTATE &&
2033 ops[-1]->op_type != OP_DBSTATE)))
2035 if (o = dofindlabel(kid, label, ops, oplimit))
2054 register PERL_CONTEXT *cx;
2055 #define GOTO_DEPTH 64
2056 OP *enterops[GOTO_DEPTH];
2058 int do_dump = (PL_op->op_type == OP_DUMP);
2059 static char must_have_label[] = "goto must have label";
2062 if (PL_op->op_flags & OPf_STACKED) {
2066 /* This egregious kludge implements goto &subroutine */
2067 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2069 register PERL_CONTEXT *cx;
2070 CV* cv = (CV*)SvRV(sv);
2076 if (!CvROOT(cv) && !CvXSUB(cv)) {
2081 /* autoloaded stub? */
2082 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2084 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2085 GvNAMELEN(gv), FALSE);
2086 if (autogv && (cv = GvCV(autogv)))
2088 tmpstr = sv_newmortal();
2089 gv_efullname3(tmpstr, gv, Nullch);
2090 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2092 DIE(aTHX_ "Goto undefined subroutine");
2095 /* First do some returnish stuff. */
2096 cxix = dopoptosub(cxstack_ix);
2098 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2099 if (cxix < cxstack_ix)
2102 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2103 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2105 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2106 /* put @_ back onto stack */
2107 AV* av = cx->blk_sub.argarray;
2109 items = AvFILLp(av) + 1;
2111 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2112 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2113 PL_stack_sp += items;
2115 SvREFCNT_dec(GvAV(PL_defgv));
2116 GvAV(PL_defgv) = cx->blk_sub.savearray;
2117 #endif /* USE_THREADS */
2118 /* abandon @_ if it got reified */
2120 (void)sv_2mortal((SV*)av); /* delay until return */
2122 av_extend(av, items-1);
2123 AvFLAGS(av) = AVf_REIFY;
2124 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2127 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2131 av = (AV*)PL_curpad[0];
2133 av = GvAV(PL_defgv);
2135 items = AvFILLp(av) + 1;
2137 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2138 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2139 PL_stack_sp += items;
2141 if (CxTYPE(cx) == CXt_SUB &&
2142 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2143 SvREFCNT_dec(cx->blk_sub.cv);
2144 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2145 LEAVE_SCOPE(oldsave);
2147 /* Now do some callish stuff. */
2150 #ifdef PERL_XSUB_OLDSTYLE
2151 if (CvOLDSTYLE(cv)) {
2152 I32 (*fp3)(int,int,int);
2157 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2158 items = (*fp3)(CvXSUBANY(cv).any_i32,
2159 mark - PL_stack_base + 1,
2161 SP = PL_stack_base + items;
2164 #endif /* PERL_XSUB_OLDSTYLE */
2169 PL_stack_sp--; /* There is no cv arg. */
2170 /* Push a mark for the start of arglist */
2172 (void)(*CvXSUB(cv))(aTHXo_ cv);
2173 /* Pop the current context like a decent sub should */
2174 POPBLOCK(cx, PL_curpm);
2175 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2178 return pop_return();
2181 AV* padlist = CvPADLIST(cv);
2182 SV** svp = AvARRAY(padlist);
2183 if (CxTYPE(cx) == CXt_EVAL) {
2184 PL_in_eval = cx->blk_eval.old_in_eval;
2185 PL_eval_root = cx->blk_eval.old_eval_root;
2186 cx->cx_type = CXt_SUB;
2187 cx->blk_sub.hasargs = 0;
2189 cx->blk_sub.cv = cv;
2190 cx->blk_sub.olddepth = CvDEPTH(cv);
2192 if (CvDEPTH(cv) < 2)
2193 (void)SvREFCNT_inc(cv);
2194 else { /* save temporaries on recursion? */
2195 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2196 sub_crush_depth(cv);
2197 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2198 AV *newpad = newAV();
2199 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2200 I32 ix = AvFILLp((AV*)svp[1]);
2201 I32 names_fill = AvFILLp((AV*)svp[0]);
2202 svp = AvARRAY(svp[0]);
2203 for ( ;ix > 0; ix--) {
2204 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2205 char *name = SvPVX(svp[ix]);
2206 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2209 /* outer lexical or anon code */
2210 av_store(newpad, ix,
2211 SvREFCNT_inc(oldpad[ix]) );
2213 else { /* our own lexical */
2215 av_store(newpad, ix, sv = (SV*)newAV());
2216 else if (*name == '%')
2217 av_store(newpad, ix, sv = (SV*)newHV());
2219 av_store(newpad, ix, sv = NEWSV(0,0));
2223 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2224 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2227 av_store(newpad, ix, sv = NEWSV(0,0));
2231 if (cx->blk_sub.hasargs) {
2234 av_store(newpad, 0, (SV*)av);
2235 AvFLAGS(av) = AVf_REIFY;
2237 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2238 AvFILLp(padlist) = CvDEPTH(cv);
2239 svp = AvARRAY(padlist);
2243 if (!cx->blk_sub.hasargs) {
2244 AV* av = (AV*)PL_curpad[0];
2246 items = AvFILLp(av) + 1;
2248 /* Mark is at the end of the stack. */
2250 Copy(AvARRAY(av), SP + 1, items, SV*);
2255 #endif /* USE_THREADS */
2256 SAVEVPTR(PL_curpad);
2257 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2259 if (cx->blk_sub.hasargs)
2260 #endif /* USE_THREADS */
2262 AV* av = (AV*)PL_curpad[0];
2266 cx->blk_sub.savearray = GvAV(PL_defgv);
2267 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2268 #endif /* USE_THREADS */
2269 cx->blk_sub.argarray = av;
2272 if (items >= AvMAX(av) + 1) {
2274 if (AvARRAY(av) != ary) {
2275 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2276 SvPVX(av) = (char*)ary;
2278 if (items >= AvMAX(av) + 1) {
2279 AvMAX(av) = items - 1;
2280 Renew(ary,items+1,SV*);
2282 SvPVX(av) = (char*)ary;
2285 Copy(mark,AvARRAY(av),items,SV*);
2286 AvFILLp(av) = items - 1;
2287 assert(!AvREAL(av));
2294 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2296 * We do not care about using sv to call CV;
2297 * it's for informational purposes only.
2299 SV *sv = GvSV(PL_DBsub);
2302 if (PERLDB_SUB_NN) {
2303 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2306 gv_efullname3(sv, CvGV(cv), Nullch);
2309 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2310 PUSHMARK( PL_stack_sp );
2311 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2315 RETURNOP(CvSTART(cv));
2319 label = SvPV(sv,n_a);
2320 if (!(do_dump || *label))
2321 DIE(aTHX_ must_have_label);
2324 else if (PL_op->op_flags & OPf_SPECIAL) {
2326 DIE(aTHX_ must_have_label);
2329 label = cPVOP->op_pv;
2331 if (label && *label) {
2336 PL_lastgotoprobe = 0;
2338 for (ix = cxstack_ix; ix >= 0; ix--) {
2340 switch (CxTYPE(cx)) {
2342 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2345 gotoprobe = cx->blk_oldcop->op_sibling;
2351 gotoprobe = cx->blk_oldcop->op_sibling;
2353 gotoprobe = PL_main_root;
2356 if (CvDEPTH(cx->blk_sub.cv)) {
2357 gotoprobe = CvROOT(cx->blk_sub.cv);
2363 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2366 DIE(aTHX_ "panic: goto");
2367 gotoprobe = PL_main_root;
2370 retop = dofindlabel(gotoprobe, label,
2371 enterops, enterops + GOTO_DEPTH);
2374 PL_lastgotoprobe = gotoprobe;
2377 DIE(aTHX_ "Can't find label %s", label);
2379 /* pop unwanted frames */
2381 if (ix < cxstack_ix) {
2388 oldsave = PL_scopestack[PL_scopestack_ix];
2389 LEAVE_SCOPE(oldsave);
2392 /* push wanted frames */
2394 if (*enterops && enterops[1]) {
2396 for (ix = 1; enterops[ix]; ix++) {
2397 PL_op = enterops[ix];
2398 /* Eventually we may want to stack the needed arguments
2399 * for each op. For now, we punt on the hard ones. */
2400 if (PL_op->op_type == OP_ENTERITER)
2401 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2402 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2410 if (!retop) retop = PL_main_start;
2412 PL_restartop = retop;
2413 PL_do_undump = TRUE;
2417 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2418 PL_do_undump = FALSE;
2434 if (anum == 1 && VMSISH_EXIT)
2438 PL_exit_flags |= PERL_EXIT_EXPECTED;
2440 PUSHs(&PL_sv_undef);
2448 NV value = SvNVx(GvSV(cCOP->cop_gv));
2449 register I32 match = I_32(value);
2452 if (((NV)match) > value)
2453 --match; /* was fractional--truncate other way */
2455 match -= cCOP->uop.scop.scop_offset;
2458 else if (match > cCOP->uop.scop.scop_max)
2459 match = cCOP->uop.scop.scop_max;
2460 PL_op = cCOP->uop.scop.scop_next[match];
2470 PL_op = PL_op->op_next; /* can't assume anything */
2473 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2474 match -= cCOP->uop.scop.scop_offset;
2477 else if (match > cCOP->uop.scop.scop_max)
2478 match = cCOP->uop.scop.scop_max;
2479 PL_op = cCOP->uop.scop.scop_next[match];
2488 S_save_lines(pTHX_ AV *array, SV *sv)
2490 register char *s = SvPVX(sv);
2491 register char *send = SvPVX(sv) + SvCUR(sv);
2493 register I32 line = 1;
2495 while (s && s < send) {
2496 SV *tmpstr = NEWSV(85,0);
2498 sv_upgrade(tmpstr, SVt_PVMG);
2499 t = strchr(s, '\n');
2505 sv_setpvn(tmpstr, s, t - s);
2506 av_store(array, line++, tmpstr);
2512 S_docatch_body(pTHX_ va_list args)
2519 S_docatch(pTHX_ OP *o)
2524 volatile PERL_SI *cursi = PL_curstackinfo;
2528 assert(CATCH_GET == TRUE);
2532 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2537 if (PL_restartop && cursi == PL_curstackinfo) {
2538 PL_op = PL_restartop;
2553 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2554 /* sv Text to convert to OP tree. */
2555 /* startop op_free() this to undo. */
2556 /* code Short string id of the caller. */
2558 dSP; /* Make POPBLOCK work. */
2561 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2564 OP *oop = PL_op, *rop;
2565 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2571 /* switch to eval mode */
2573 if (PL_curcop == &PL_compiling) {
2574 SAVECOPSTASH(&PL_compiling);
2575 CopSTASH_set(&PL_compiling, PL_curstash);
2577 SAVECOPFILE(&PL_compiling);
2578 SAVECOPLINE(&PL_compiling);
2579 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2580 CopFILE_set(&PL_compiling, tmpbuf+2);
2581 CopLINE_set(&PL_compiling, 1);
2582 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2583 deleting the eval's FILEGV from the stash before gv_check() runs
2584 (i.e. before run-time proper). To work around the coredump that
2585 ensues, we always turn GvMULTI_on for any globals that were
2586 introduced within evals. See force_ident(). GSAR 96-10-12 */
2587 safestr = savepv(tmpbuf);
2588 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2590 #ifdef OP_IN_REGISTER
2598 PL_op->op_type = OP_ENTEREVAL;
2599 PL_op->op_flags = 0; /* Avoid uninit warning. */
2600 PUSHBLOCK(cx, CXt_EVAL, SP);
2601 PUSHEVAL(cx, 0, Nullgv);
2602 rop = doeval(G_SCALAR, startop);
2603 POPBLOCK(cx,PL_curpm);
2606 (*startop)->op_type = OP_NULL;
2607 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2609 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2611 if (PL_curcop == &PL_compiling)
2612 PL_compiling.op_private = PL_hints;
2613 #ifdef OP_IN_REGISTER
2619 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2621 S_doeval(pTHX_ int gimme, OP** startop)
2629 PL_in_eval = EVAL_INEVAL;
2633 /* set up a scratch pad */
2636 SAVEVPTR(PL_curpad);
2637 SAVESPTR(PL_comppad);
2638 SAVESPTR(PL_comppad_name);
2639 SAVEI32(PL_comppad_name_fill);
2640 SAVEI32(PL_min_intro_pending);
2641 SAVEI32(PL_max_intro_pending);
2644 for (i = cxstack_ix - 1; i >= 0; i--) {
2645 PERL_CONTEXT *cx = &cxstack[i];
2646 if (CxTYPE(cx) == CXt_EVAL)
2648 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2649 caller = cx->blk_sub.cv;
2654 SAVESPTR(PL_compcv);
2655 PL_compcv = (CV*)NEWSV(1104,0);
2656 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2657 CvEVAL_on(PL_compcv);
2659 CvOWNER(PL_compcv) = 0;
2660 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2661 MUTEX_INIT(CvMUTEXP(PL_compcv));
2662 #endif /* USE_THREADS */
2664 PL_comppad = newAV();
2665 av_push(PL_comppad, Nullsv);
2666 PL_curpad = AvARRAY(PL_comppad);
2667 PL_comppad_name = newAV();
2668 PL_comppad_name_fill = 0;
2669 PL_min_intro_pending = 0;
2672 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2673 PL_curpad[0] = (SV*)newAV();
2674 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2675 #endif /* USE_THREADS */
2677 comppadlist = newAV();
2678 AvREAL_off(comppadlist);
2679 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2680 av_store(comppadlist, 1, (SV*)PL_comppad);
2681 CvPADLIST(PL_compcv) = comppadlist;
2683 if (!saveop || saveop->op_type != OP_REQUIRE)
2684 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2686 SAVEFREESV(PL_compcv);
2688 /* make sure we compile in the right package */
2690 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2691 SAVESPTR(PL_curstash);
2692 PL_curstash = CopSTASH(PL_curcop);
2694 SAVESPTR(PL_beginav);
2695 PL_beginav = newAV();
2696 SAVEFREESV(PL_beginav);
2698 /* try to compile it */
2700 PL_eval_root = Nullop;
2702 PL_curcop = &PL_compiling;
2703 PL_curcop->cop_arybase = 0;
2704 SvREFCNT_dec(PL_rs);
2705 PL_rs = newSVpvn("\n", 1);
2706 if (saveop && saveop->op_flags & OPf_SPECIAL)
2707 PL_in_eval |= EVAL_KEEPERR;
2710 if (yyparse() || PL_error_count || !PL_eval_root) {
2714 I32 optype = 0; /* Might be reset by POPEVAL. */
2719 op_free(PL_eval_root);
2720 PL_eval_root = Nullop;
2722 SP = PL_stack_base + POPMARK; /* pop original mark */
2724 POPBLOCK(cx,PL_curpm);
2730 if (optype == OP_REQUIRE) {
2731 char* msg = SvPVx(ERRSV, n_a);
2732 DIE(aTHX_ "%sCompilation failed in require",
2733 *msg ? msg : "Unknown error\n");
2736 char* msg = SvPVx(ERRSV, n_a);
2738 POPBLOCK(cx,PL_curpm);
2740 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2741 (*msg ? msg : "Unknown error\n"));
2743 SvREFCNT_dec(PL_rs);
2744 PL_rs = SvREFCNT_inc(PL_nrs);
2746 MUTEX_LOCK(&PL_eval_mutex);
2748 COND_SIGNAL(&PL_eval_cond);
2749 MUTEX_UNLOCK(&PL_eval_mutex);
2750 #endif /* USE_THREADS */
2753 SvREFCNT_dec(PL_rs);
2754 PL_rs = SvREFCNT_inc(PL_nrs);
2755 CopLINE_set(&PL_compiling, 0);
2757 *startop = PL_eval_root;
2758 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2759 CvOUTSIDE(PL_compcv) = Nullcv;
2761 SAVEFREEOP(PL_eval_root);
2763 scalarvoid(PL_eval_root);
2764 else if (gimme & G_ARRAY)
2767 scalar(PL_eval_root);
2769 DEBUG_x(dump_eval());
2771 /* Register with debugger: */
2772 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2773 CV *cv = get_cv("DB::postponed", FALSE);
2777 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2779 call_sv((SV*)cv, G_DISCARD);
2783 /* compiled okay, so do it */
2785 CvDEPTH(PL_compcv) = 1;
2786 SP = PL_stack_base + POPMARK; /* pop original mark */
2787 PL_op = saveop; /* The caller may need it. */
2789 MUTEX_LOCK(&PL_eval_mutex);
2791 COND_SIGNAL(&PL_eval_cond);
2792 MUTEX_UNLOCK(&PL_eval_mutex);
2793 #endif /* USE_THREADS */
2795 RETURNOP(PL_eval_start);
2799 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2801 STRLEN namelen = strlen(name);
2804 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2805 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2806 char *pmc = SvPV_nolen(pmcsv);
2809 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2810 fp = PerlIO_open(name, mode);
2813 if (PerlLIO_stat(name, &pmstat) < 0 ||
2814 pmstat.st_mtime < pmcstat.st_mtime)
2816 fp = PerlIO_open(pmc, mode);
2819 fp = PerlIO_open(name, mode);
2822 SvREFCNT_dec(pmcsv);
2825 fp = PerlIO_open(name, mode);
2833 register PERL_CONTEXT *cx;
2838 SV *namesv = Nullsv;
2840 I32 gimme = G_SCALAR;
2841 PerlIO *tryrsfp = 0;
2843 int filter_has_file = 0;
2844 GV *filter_child_proc = 0;
2845 SV *filter_state = 0;
2851 if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */
2853 U8 *s = (U8*)SvPVX(sv);
2854 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2856 rev = utf8_to_uv(s, &len);
2859 ver = utf8_to_uv(s, &len);
2862 sver = utf8_to_uv(s, &len);
2871 if (PERL_REVISION < rev
2872 || (PERL_REVISION == rev
2873 && (PERL_VERSION < ver
2874 || (PERL_VERSION == ver
2875 && PERL_SUBVERSION < sver))))
2877 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2878 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2879 PERL_VERSION, PERL_SUBVERSION);
2882 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2885 ver = (UV)((n-rev)*1000);
2886 sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2888 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2889 + ((NV)PERL_SUBVERSION/(NV)1000000)
2890 + 0.00000099 < SvNV(sv))
2892 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2893 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2894 PERL_VERSION, PERL_SUBVERSION);
2899 name = SvPV(sv, len);
2900 if (!(name && len > 0 && *name))
2901 DIE(aTHX_ "Null filename used");
2902 TAINT_PROPER("require");
2903 if (PL_op->op_type == OP_REQUIRE &&
2904 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2905 *svp != &PL_sv_undef)
2908 /* prepare to compile file */
2910 if (PERL_FILE_IS_ABSOLUTE(name)
2911 || (*name == '.' && (name[1] == '/' ||
2912 (name[1] == '.' && name[2] == '/'))))
2915 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2918 AV *ar = GvAVn(PL_incgv);
2922 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2925 namesv = NEWSV(806, 0);
2926 for (i = 0; i <= AvFILL(ar); i++) {
2927 SV *dirsv = *av_fetch(ar, i, TRUE);
2933 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2934 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2937 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2938 PTR2UV(SvANY(loader)), name);
2939 tryname = SvPVX(namesv);
2950 count = call_sv(loader, G_ARRAY);
2960 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2964 if (SvTYPE(arg) == SVt_PVGV) {
2965 IO *io = GvIO((GV *)arg);
2970 tryrsfp = IoIFP(io);
2971 if (IoTYPE(io) == '|') {
2972 /* reading from a child process doesn't
2973 nest -- when returning from reading
2974 the inner module, the outer one is
2975 unreadable (closed?) I've tried to
2976 save the gv to manage the lifespan of
2977 the pipe, but this didn't help. XXX */
2978 filter_child_proc = (GV *)arg;
2979 (void)SvREFCNT_inc(filter_child_proc);
2982 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2983 PerlIO_close(IoOFP(io));
2995 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2997 (void)SvREFCNT_inc(filter_sub);
3000 filter_state = SP[i];
3001 (void)SvREFCNT_inc(filter_state);
3005 tryrsfp = PerlIO_open("/dev/null",
3019 filter_has_file = 0;
3020 if (filter_child_proc) {
3021 SvREFCNT_dec(filter_child_proc);
3022 filter_child_proc = 0;
3025 SvREFCNT_dec(filter_state);
3029 SvREFCNT_dec(filter_sub);
3034 char *dir = SvPVx(dirsv, n_a);
3037 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3039 sv_setpv(namesv, unixdir);
3040 sv_catpv(namesv, unixname);
3042 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3044 TAINT_PROPER("require");
3045 tryname = SvPVX(namesv);
3046 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3048 if (tryname[0] == '.' && tryname[1] == '/')
3056 SAVECOPFILE(&PL_compiling);
3057 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3058 SvREFCNT_dec(namesv);
3060 if (PL_op->op_type == OP_REQUIRE) {
3061 char *msgstr = name;
3062 if (namesv) { /* did we lookup @INC? */
3063 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3064 SV *dirmsgsv = NEWSV(0, 0);
3065 AV *ar = GvAVn(PL_incgv);
3067 sv_catpvn(msg, " in @INC", 8);
3068 if (instr(SvPVX(msg), ".h "))
3069 sv_catpv(msg, " (change .h to .ph maybe?)");
3070 if (instr(SvPVX(msg), ".ph "))
3071 sv_catpv(msg, " (did you run h2ph?)");
3072 sv_catpv(msg, " (@INC contains:");
3073 for (i = 0; i <= AvFILL(ar); i++) {
3074 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3075 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3076 sv_catsv(msg, dirmsgsv);
3078 sv_catpvn(msg, ")", 1);
3079 SvREFCNT_dec(dirmsgsv);
3080 msgstr = SvPV_nolen(msg);
3082 DIE(aTHX_ "Can't locate %s", msgstr);
3088 SETERRNO(0, SS$_NORMAL);
3090 /* Assume success here to prevent recursive requirement. */
3091 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3092 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3096 lex_start(sv_2mortal(newSVpvn("",0)));
3097 SAVEGENERICSV(PL_rsfp_filters);
3098 PL_rsfp_filters = Nullav;
3103 SAVESPTR(PL_compiling.cop_warnings);
3104 if (PL_dowarn & G_WARN_ALL_ON)
3105 PL_compiling.cop_warnings = WARN_ALL ;
3106 else if (PL_dowarn & G_WARN_ALL_OFF)
3107 PL_compiling.cop_warnings = WARN_NONE ;
3109 PL_compiling.cop_warnings = WARN_STD ;
3111 if (filter_sub || filter_child_proc) {
3112 SV *datasv = filter_add(run_user_filter, Nullsv);
3113 IoLINES(datasv) = filter_has_file;
3114 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3115 IoTOP_GV(datasv) = (GV *)filter_state;
3116 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3119 /* switch to eval mode */
3120 push_return(PL_op->op_next);
3121 PUSHBLOCK(cx, CXt_EVAL, SP);
3122 PUSHEVAL(cx, name, Nullgv);
3124 SAVECOPLINE(&PL_compiling);
3125 CopLINE_set(&PL_compiling, 0);
3129 MUTEX_LOCK(&PL_eval_mutex);
3130 if (PL_eval_owner && PL_eval_owner != thr)
3131 while (PL_eval_owner)
3132 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3133 PL_eval_owner = thr;
3134 MUTEX_UNLOCK(&PL_eval_mutex);
3135 #endif /* USE_THREADS */
3136 return DOCATCH(doeval(G_SCALAR, NULL));
3141 return pp_require();
3147 register PERL_CONTEXT *cx;
3149 I32 gimme = GIMME_V, was = PL_sub_generation;
3150 char tmpbuf[TYPE_DIGITS(long) + 12];
3155 if (!SvPV(sv,len) || !len)
3157 TAINT_PROPER("eval");
3163 /* switch to eval mode */
3165 SAVECOPFILE(&PL_compiling);
3166 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3167 CopFILE_set(&PL_compiling, tmpbuf+2);
3168 CopLINE_set(&PL_compiling, 1);
3169 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3170 deleting the eval's FILEGV from the stash before gv_check() runs
3171 (i.e. before run-time proper). To work around the coredump that
3172 ensues, we always turn GvMULTI_on for any globals that were
3173 introduced within evals. See force_ident(). GSAR 96-10-12 */
3174 safestr = savepv(tmpbuf);
3175 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3177 PL_hints = PL_op->op_targ;
3178 SAVESPTR(PL_compiling.cop_warnings);
3179 if (!specialWARN(PL_compiling.cop_warnings)) {
3180 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3181 SAVEFREESV(PL_compiling.cop_warnings) ;
3184 push_return(PL_op->op_next);
3185 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3186 PUSHEVAL(cx, 0, Nullgv);
3188 /* prepare to compile string */
3190 if (PERLDB_LINE && PL_curstash != PL_debstash)
3191 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3194 MUTEX_LOCK(&PL_eval_mutex);
3195 if (PL_eval_owner && PL_eval_owner != thr)
3196 while (PL_eval_owner)
3197 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3198 PL_eval_owner = thr;
3199 MUTEX_UNLOCK(&PL_eval_mutex);
3200 #endif /* USE_THREADS */
3201 ret = doeval(gimme, NULL);
3202 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3203 && ret != PL_op->op_next) { /* Successive compilation. */
3204 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3206 return DOCATCH(ret);
3216 register PERL_CONTEXT *cx;
3218 U8 save_flags = PL_op -> op_flags;
3223 retop = pop_return();
3226 if (gimme == G_VOID)
3228 else if (gimme == G_SCALAR) {
3231 if (SvFLAGS(TOPs) & SVs_TEMP)
3234 *MARK = sv_mortalcopy(TOPs);
3238 *MARK = &PL_sv_undef;
3243 /* in case LEAVE wipes old return values */
3244 for (mark = newsp + 1; mark <= SP; mark++) {
3245 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3246 *mark = sv_mortalcopy(*mark);
3247 TAINT_NOT; /* Each item is independent */
3251 PL_curpm = newpm; /* Don't pop $1 et al till now */
3253 if (AvFILLp(PL_comppad_name) >= 0)
3257 assert(CvDEPTH(PL_compcv) == 1);
3259 CvDEPTH(PL_compcv) = 0;
3262 if (optype == OP_REQUIRE &&
3263 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3265 /* Unassume the success we assumed earlier. */
3266 char *name = cx->blk_eval.old_name;
3267 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3268 retop = Perl_die(aTHX_ "%s did not return a true value", name);
3269 /* die_where() did LEAVE, or we won't be here */
3273 if (!(save_flags & OPf_SPECIAL))
3283 register PERL_CONTEXT *cx;
3284 I32 gimme = GIMME_V;
3289 push_return(cLOGOP->op_other->op_next);
3290 PUSHBLOCK(cx, CXt_EVAL, SP);
3292 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3294 PL_in_eval = EVAL_INEVAL;
3297 return DOCATCH(PL_op->op_next);
3307 register PERL_CONTEXT *cx;
3315 if (gimme == G_VOID)
3317 else if (gimme == G_SCALAR) {
3320 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3323 *MARK = sv_mortalcopy(TOPs);
3327 *MARK = &PL_sv_undef;
3332 /* in case LEAVE wipes old return values */
3333 for (mark = newsp + 1; mark <= SP; mark++) {
3334 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3335 *mark = sv_mortalcopy(*mark);
3336 TAINT_NOT; /* Each item is independent */
3340 PL_curpm = newpm; /* Don't pop $1 et al till now */
3348 S_doparseform(pTHX_ SV *sv)
3351 register char *s = SvPV_force(sv, len);
3352 register char *send = s + len;
3353 register char *base;
3354 register I32 skipspaces = 0;
3357 bool postspace = FALSE;
3365 Perl_croak(aTHX_ "Null picture in formline");
3367 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3372 *fpc++ = FF_LINEMARK;
3373 noblank = repeat = FALSE;
3391 case ' ': case '\t':
3402 *fpc++ = FF_LITERAL;
3410 *fpc++ = skipspaces;
3414 *fpc++ = FF_NEWLINE;
3418 arg = fpc - linepc + 1;
3425 *fpc++ = FF_LINEMARK;
3426 noblank = repeat = FALSE;
3435 ischop = s[-1] == '^';
3441 arg = (s - base) - 1;
3443 *fpc++ = FF_LITERAL;
3452 *fpc++ = FF_LINEGLOB;
3454 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3455 arg = ischop ? 512 : 0;
3465 arg |= 256 + (s - f);
3467 *fpc++ = s - base; /* fieldsize for FETCH */
3468 *fpc++ = FF_DECIMAL;
3473 bool ismore = FALSE;
3476 while (*++s == '>') ;
3477 prespace = FF_SPACE;
3479 else if (*s == '|') {
3480 while (*++s == '|') ;
3481 prespace = FF_HALFSPACE;
3486 while (*++s == '<') ;
3489 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3493 *fpc++ = s - base; /* fieldsize for FETCH */
3495 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3513 { /* need to jump to the next word */
3515 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3516 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3517 s = SvPVX(sv) + SvCUR(sv) + z;
3519 Copy(fops, s, arg, U16);
3521 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3526 * The rest of this file was derived from source code contributed
3529 * NOTE: this code was derived from Tom Horsley's qsort replacement
3530 * and should not be confused with the original code.
3533 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3535 Permission granted to distribute under the same terms as perl which are
3538 This program is free software; you can redistribute it and/or modify
3539 it under the terms of either:
3541 a) the GNU General Public License as published by the Free
3542 Software Foundation; either version 1, or (at your option) any
3545 b) the "Artistic License" which comes with this Kit.
3547 Details on the perl license can be found in the perl source code which
3548 may be located via the www.perl.com web page.
3550 This is the most wonderfulest possible qsort I can come up with (and
3551 still be mostly portable) My (limited) tests indicate it consistently
3552 does about 20% fewer calls to compare than does the qsort in the Visual
3553 C++ library, other vendors may vary.
3555 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3556 others I invented myself (or more likely re-invented since they seemed
3557 pretty obvious once I watched the algorithm operate for a while).
3559 Most of this code was written while watching the Marlins sweep the Giants
3560 in the 1997 National League Playoffs - no Braves fans allowed to use this
3561 code (just kidding :-).
3563 I realize that if I wanted to be true to the perl tradition, the only
3564 comment in this file would be something like:
3566 ...they shuffled back towards the rear of the line. 'No, not at the
3567 rear!' the slave-driver shouted. 'Three files up. And stay there...
3569 However, I really needed to violate that tradition just so I could keep
3570 track of what happens myself, not to mention some poor fool trying to
3571 understand this years from now :-).
3574 /* ********************************************************** Configuration */
3576 #ifndef QSORT_ORDER_GUESS
3577 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3580 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3581 future processing - a good max upper bound is log base 2 of memory size
3582 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3583 safely be smaller than that since the program is taking up some space and
3584 most operating systems only let you grab some subset of contiguous
3585 memory (not to mention that you are normally sorting data larger than
3586 1 byte element size :-).
3588 #ifndef QSORT_MAX_STACK
3589 #define QSORT_MAX_STACK 32
3592 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3593 Anything bigger and we use qsort. If you make this too small, the qsort
3594 will probably break (or become less efficient), because it doesn't expect
3595 the middle element of a partition to be the same as the right or left -
3596 you have been warned).
3598 #ifndef QSORT_BREAK_EVEN
3599 #define QSORT_BREAK_EVEN 6
3602 /* ************************************************************* Data Types */
3604 /* hold left and right index values of a partition waiting to be sorted (the
3605 partition includes both left and right - right is NOT one past the end or
3606 anything like that).
3608 struct partition_stack_entry {
3611 #ifdef QSORT_ORDER_GUESS
3612 int qsort_break_even;
3616 /* ******************************************************* Shorthand Macros */
3618 /* Note that these macros will be used from inside the qsort function where
3619 we happen to know that the variable 'elt_size' contains the size of an
3620 array element and the variable 'temp' points to enough space to hold a
3621 temp element and the variable 'array' points to the array being sorted
3622 and 'compare' is the pointer to the compare routine.
3624 Also note that there are very many highly architecture specific ways
3625 these might be sped up, but this is simply the most generally portable
3626 code I could think of.
3629 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3631 #define qsort_cmp(elt1, elt2) \
3632 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3634 #ifdef QSORT_ORDER_GUESS
3635 #define QSORT_NOTICE_SWAP swapped++;
3637 #define QSORT_NOTICE_SWAP
3640 /* swaps contents of array elements elt1, elt2.
3642 #define qsort_swap(elt1, elt2) \
3645 temp = array[elt1]; \
3646 array[elt1] = array[elt2]; \
3647 array[elt2] = temp; \
3650 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3651 elt3 and elt3 gets elt1.
3653 #define qsort_rotate(elt1, elt2, elt3) \
3656 temp = array[elt1]; \
3657 array[elt1] = array[elt2]; \
3658 array[elt2] = array[elt3]; \
3659 array[elt3] = temp; \
3662 /* ************************************************************ Debug stuff */
3669 return; /* good place to set a breakpoint */
3672 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3675 doqsort_all_asserts(
3679 int (*compare)(const void * elt1, const void * elt2),
3680 int pc_left, int pc_right, int u_left, int u_right)
3684 qsort_assert(pc_left <= pc_right);
3685 qsort_assert(u_right < pc_left);
3686 qsort_assert(pc_right < u_left);
3687 for (i = u_right + 1; i < pc_left; ++i) {
3688 qsort_assert(qsort_cmp(i, pc_left) < 0);
3690 for (i = pc_left; i < pc_right; ++i) {
3691 qsort_assert(qsort_cmp(i, pc_right) == 0);
3693 for (i = pc_right + 1; i < u_left; ++i) {
3694 qsort_assert(qsort_cmp(pc_right, i) < 0);
3698 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3699 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3700 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3704 #define qsort_assert(t) ((void)0)
3706 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3710 /* ****************************************************************** qsort */
3713 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3717 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3718 int next_stack_entry = 0;
3722 #ifdef QSORT_ORDER_GUESS
3723 int qsort_break_even;
3727 /* Make sure we actually have work to do.
3729 if (num_elts <= 1) {
3733 /* Setup the initial partition definition and fall into the sorting loop
3736 part_right = (int)(num_elts - 1);
3737 #ifdef QSORT_ORDER_GUESS
3738 qsort_break_even = QSORT_BREAK_EVEN;
3740 #define qsort_break_even QSORT_BREAK_EVEN
3743 if ((part_right - part_left) >= qsort_break_even) {
3744 /* OK, this is gonna get hairy, so lets try to document all the
3745 concepts and abbreviations and variables and what they keep
3748 pc: pivot chunk - the set of array elements we accumulate in the
3749 middle of the partition, all equal in value to the original
3750 pivot element selected. The pc is defined by:
3752 pc_left - the leftmost array index of the pc
3753 pc_right - the rightmost array index of the pc
3755 we start with pc_left == pc_right and only one element
3756 in the pivot chunk (but it can grow during the scan).
3758 u: uncompared elements - the set of elements in the partition
3759 we have not yet compared to the pivot value. There are two
3760 uncompared sets during the scan - one to the left of the pc
3761 and one to the right.
3763 u_right - the rightmost index of the left side's uncompared set
3764 u_left - the leftmost index of the right side's uncompared set
3766 The leftmost index of the left sides's uncompared set
3767 doesn't need its own variable because it is always defined
3768 by the leftmost edge of the whole partition (part_left). The
3769 same goes for the rightmost edge of the right partition
3772 We know there are no uncompared elements on the left once we
3773 get u_right < part_left and no uncompared elements on the
3774 right once u_left > part_right. When both these conditions
3775 are met, we have completed the scan of the partition.
3777 Any elements which are between the pivot chunk and the
3778 uncompared elements should be less than the pivot value on
3779 the left side and greater than the pivot value on the right
3780 side (in fact, the goal of the whole algorithm is to arrange
3781 for that to be true and make the groups of less-than and
3782 greater-then elements into new partitions to sort again).
3784 As you marvel at the complexity of the code and wonder why it
3785 has to be so confusing. Consider some of the things this level
3786 of confusion brings:
3788 Once I do a compare, I squeeze every ounce of juice out of it. I
3789 never do compare calls I don't have to do, and I certainly never
3792 I also never swap any elements unless I can prove there is a
3793 good reason. Many sort algorithms will swap a known value with
3794 an uncompared value just to get things in the right place (or
3795 avoid complexity :-), but that uncompared value, once it gets
3796 compared, may then have to be swapped again. A lot of the
3797 complexity of this code is due to the fact that it never swaps
3798 anything except compared values, and it only swaps them when the
3799 compare shows they are out of position.
3801 int pc_left, pc_right;
3802 int u_right, u_left;
3806 pc_left = ((part_left + part_right) / 2);
3808 u_right = pc_left - 1;
3809 u_left = pc_right + 1;
3811 /* Qsort works best when the pivot value is also the median value
3812 in the partition (unfortunately you can't find the median value
3813 without first sorting :-), so to give the algorithm a helping
3814 hand, we pick 3 elements and sort them and use the median value
3815 of that tiny set as the pivot value.
3817 Some versions of qsort like to use the left middle and right as
3818 the 3 elements to sort so they can insure the ends of the
3819 partition will contain values which will stop the scan in the
3820 compare loop, but when you have to call an arbitrarily complex
3821 routine to do a compare, its really better to just keep track of
3822 array index values to know when you hit the edge of the
3823 partition and avoid the extra compare. An even better reason to
3824 avoid using a compare call is the fact that you can drop off the
3825 edge of the array if someone foolishly provides you with an
3826 unstable compare function that doesn't always provide consistent
3829 So, since it is simpler for us to compare the three adjacent
3830 elements in the middle of the partition, those are the ones we
3831 pick here (conveniently pointed at by u_right, pc_left, and
3832 u_left). The values of the left, center, and right elements
3833 are refered to as l c and r in the following comments.
3836 #ifdef QSORT_ORDER_GUESS
3839 s = qsort_cmp(u_right, pc_left);
3842 s = qsort_cmp(pc_left, u_left);
3843 /* if l < c, c < r - already in order - nothing to do */
3845 /* l < c, c == r - already in order, pc grows */
3847 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3849 /* l < c, c > r - need to know more */
3850 s = qsort_cmp(u_right, u_left);
3852 /* l < c, c > r, l < r - swap c & r to get ordered */
3853 qsort_swap(pc_left, u_left);
3854 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3855 } else if (s == 0) {
3856 /* l < c, c > r, l == r - swap c&r, grow pc */
3857 qsort_swap(pc_left, u_left);
3859 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3861 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3862 qsort_rotate(pc_left, u_right, u_left);
3863 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3866 } else if (s == 0) {
3868 s = qsort_cmp(pc_left, u_left);
3870 /* l == c, c < r - already in order, grow pc */
3872 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3873 } else if (s == 0) {
3874 /* l == c, c == r - already in order, grow pc both ways */
3877 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3879 /* l == c, c > r - swap l & r, grow pc */
3880 qsort_swap(u_right, u_left);
3882 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3886 s = qsort_cmp(pc_left, u_left);
3888 /* l > c, c < r - need to know more */
3889 s = qsort_cmp(u_right, u_left);
3891 /* l > c, c < r, l < r - swap l & c to get ordered */
3892 qsort_swap(u_right, pc_left);
3893 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3894 } else if (s == 0) {
3895 /* l > c, c < r, l == r - swap l & c, grow pc */
3896 qsort_swap(u_right, pc_left);
3898 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3900 /* l > c, c < r, l > r - rotate lcr into crl to order */
3901 qsort_rotate(u_right, pc_left, u_left);
3902 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3904 } else if (s == 0) {
3905 /* l > c, c == r - swap ends, grow pc */
3906 qsort_swap(u_right, u_left);
3908 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3910 /* l > c, c > r - swap ends to get in order */
3911 qsort_swap(u_right, u_left);
3912 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3915 /* We now know the 3 middle elements have been compared and
3916 arranged in the desired order, so we can shrink the uncompared
3921 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3923 /* The above massive nested if was the simple part :-). We now have
3924 the middle 3 elements ordered and we need to scan through the
3925 uncompared sets on either side, swapping elements that are on
3926 the wrong side or simply shuffling equal elements around to get
3927 all equal elements into the pivot chunk.
3931 int still_work_on_left;
3932 int still_work_on_right;
3934 /* Scan the uncompared values on the left. If I find a value
3935 equal to the pivot value, move it over so it is adjacent to
3936 the pivot chunk and expand the pivot chunk. If I find a value
3937 less than the pivot value, then just leave it - its already
3938 on the correct side of the partition. If I find a greater
3939 value, then stop the scan.
3941 while (still_work_on_left = (u_right >= part_left)) {
3942 s = qsort_cmp(u_right, pc_left);
3945 } else if (s == 0) {
3947 if (pc_left != u_right) {
3948 qsort_swap(u_right, pc_left);
3954 qsort_assert(u_right < pc_left);
3955 qsort_assert(pc_left <= pc_right);
3956 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3957 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3960 /* Do a mirror image scan of uncompared values on the right
3962 while (still_work_on_right = (u_left <= part_right)) {
3963 s = qsort_cmp(pc_right, u_left);
3966 } else if (s == 0) {
3968 if (pc_right != u_left) {
3969 qsort_swap(pc_right, u_left);
3975 qsort_assert(u_left > pc_right);
3976 qsort_assert(pc_left <= pc_right);
3977 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3978 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3981 if (still_work_on_left) {
3982 /* I know I have a value on the left side which needs to be
3983 on the right side, but I need to know more to decide
3984 exactly the best thing to do with it.
3986 if (still_work_on_right) {
3987 /* I know I have values on both side which are out of
3988 position. This is a big win because I kill two birds
3989 with one swap (so to speak). I can advance the
3990 uncompared pointers on both sides after swapping both
3991 of them into the right place.
3993 qsort_swap(u_right, u_left);
3996 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3998 /* I have an out of position value on the left, but the
3999 right is fully scanned, so I "slide" the pivot chunk
4000 and any less-than values left one to make room for the
4001 greater value over on the right. If the out of position
4002 value is immediately adjacent to the pivot chunk (there
4003 are no less-than values), I can do that with a swap,
4004 otherwise, I have to rotate one of the less than values
4005 into the former position of the out of position value
4006 and the right end of the pivot chunk into the left end
4010 if (pc_left == u_right) {
4011 qsort_swap(u_right, pc_right);
4012 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4014 qsort_rotate(u_right, pc_left, pc_right);
4015 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4020 } else if (still_work_on_right) {
4021 /* Mirror image of complex case above: I have an out of
4022 position value on the right, but the left is fully
4023 scanned, so I need to shuffle things around to make room
4024 for the right value on the left.
4027 if (pc_right == u_left) {
4028 qsort_swap(u_left, pc_left);
4029 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4031 qsort_rotate(pc_right, pc_left, u_left);
4032 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4037 /* No more scanning required on either side of partition,
4038 break out of loop and figure out next set of partitions
4044 /* The elements in the pivot chunk are now in the right place. They
4045 will never move or be compared again. All I have to do is decide
4046 what to do with the stuff to the left and right of the pivot
4049 Notes on the QSORT_ORDER_GUESS ifdef code:
4051 1. If I just built these partitions without swapping any (or
4052 very many) elements, there is a chance that the elements are
4053 already ordered properly (being properly ordered will
4054 certainly result in no swapping, but the converse can't be
4057 2. A (properly written) insertion sort will run faster on
4058 already ordered data than qsort will.
4060 3. Perhaps there is some way to make a good guess about
4061 switching to an insertion sort earlier than partition size 6
4062 (for instance - we could save the partition size on the stack
4063 and increase the size each time we find we didn't swap, thus
4064 switching to insertion sort earlier for partitions with a
4065 history of not swapping).
4067 4. Naturally, if I just switch right away, it will make
4068 artificial benchmarks with pure ascending (or descending)
4069 data look really good, but is that a good reason in general?
4073 #ifdef QSORT_ORDER_GUESS
4075 #if QSORT_ORDER_GUESS == 1
4076 qsort_break_even = (part_right - part_left) + 1;
4078 #if QSORT_ORDER_GUESS == 2
4079 qsort_break_even *= 2;
4081 #if QSORT_ORDER_GUESS == 3
4082 int prev_break = qsort_break_even;
4083 qsort_break_even *= qsort_break_even;
4084 if (qsort_break_even < prev_break) {
4085 qsort_break_even = (part_right - part_left) + 1;
4089 qsort_break_even = QSORT_BREAK_EVEN;
4093 if (part_left < pc_left) {
4094 /* There are elements on the left which need more processing.
4095 Check the right as well before deciding what to do.
4097 if (pc_right < part_right) {
4098 /* We have two partitions to be sorted. Stack the biggest one
4099 and process the smallest one on the next iteration. This
4100 minimizes the stack height by insuring that any additional
4101 stack entries must come from the smallest partition which
4102 (because it is smallest) will have the fewest
4103 opportunities to generate additional stack entries.
4105 if ((part_right - pc_right) > (pc_left - part_left)) {
4106 /* stack the right partition, process the left */
4107 partition_stack[next_stack_entry].left = pc_right + 1;
4108 partition_stack[next_stack_entry].right = part_right;
4109 #ifdef QSORT_ORDER_GUESS
4110 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4112 part_right = pc_left - 1;
4114 /* stack the left partition, process the right */
4115 partition_stack[next_stack_entry].left = part_left;
4116 partition_stack[next_stack_entry].right = pc_left - 1;
4117 #ifdef QSORT_ORDER_GUESS
4118 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4120 part_left = pc_right + 1;
4122 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4125 /* The elements on the left are the only remaining elements
4126 that need sorting, arrange for them to be processed as the
4129 part_right = pc_left - 1;
4131 } else if (pc_right < part_right) {
4132 /* There is only one chunk on the right to be sorted, make it
4133 the new partition and loop back around.
4135 part_left = pc_right + 1;
4137 /* This whole partition wound up in the pivot chunk, so
4138 we need to get a new partition off the stack.
4140 if (next_stack_entry == 0) {
4141 /* the stack is empty - we are done */
4145 part_left = partition_stack[next_stack_entry].left;
4146 part_right = partition_stack[next_stack_entry].right;
4147 #ifdef QSORT_ORDER_GUESS
4148 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4152 /* This partition is too small to fool with qsort complexity, just
4153 do an ordinary insertion sort to minimize overhead.
4156 /* Assume 1st element is in right place already, and start checking
4157 at 2nd element to see where it should be inserted.
4159 for (i = part_left + 1; i <= part_right; ++i) {
4161 /* Scan (backwards - just in case 'i' is already in right place)
4162 through the elements already sorted to see if the ith element
4163 belongs ahead of one of them.
4165 for (j = i - 1; j >= part_left; --j) {
4166 if (qsort_cmp(i, j) >= 0) {
4167 /* i belongs right after j
4174 /* Looks like we really need to move some things
4178 for (k = i - 1; k >= j; --k)
4179 array[k + 1] = array[k];
4184 /* That partition is now sorted, grab the next one, or get out
4185 of the loop if there aren't any more.
4188 if (next_stack_entry == 0) {
4189 /* the stack is empty - we are done */
4193 part_left = partition_stack[next_stack_entry].left;
4194 part_right = partition_stack[next_stack_entry].right;
4195 #ifdef QSORT_ORDER_GUESS
4196 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4201 /* Believe it or not, the array is sorted at this point! */
4213 sortcv(pTHXo_ SV *a, SV *b)
4216 I32 oldsaveix = PL_savestack_ix;
4217 I32 oldscopeix = PL_scopestack_ix;
4219 GvSV(PL_firstgv) = a;
4220 GvSV(PL_secondgv) = b;
4221 PL_stack_sp = PL_stack_base;
4224 if (PL_stack_sp != PL_stack_base + 1)
4225 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4226 if (!SvNIOKp(*PL_stack_sp))
4227 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4228 result = SvIV(*PL_stack_sp);
4229 while (PL_scopestack_ix > oldscopeix) {
4232 leave_scope(oldsaveix);
4237 sortcv_stacked(pTHXo_ SV *a, SV *b)
4240 I32 oldsaveix = PL_savestack_ix;
4241 I32 oldscopeix = PL_scopestack_ix;
4246 av = (AV*)PL_curpad[0];
4248 av = GvAV(PL_defgv);
4251 if (AvMAX(av) < 1) {
4252 SV** ary = AvALLOC(av);
4253 if (AvARRAY(av) != ary) {
4254 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4255 SvPVX(av) = (char*)ary;
4257 if (AvMAX(av) < 1) {
4260 SvPVX(av) = (char*)ary;
4267 PL_stack_sp = PL_stack_base;
4270 if (PL_stack_sp != PL_stack_base + 1)
4271 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4272 if (!SvNIOKp(*PL_stack_sp))
4273 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4274 result = SvIV(*PL_stack_sp);
4275 while (PL_scopestack_ix > oldscopeix) {
4278 leave_scope(oldsaveix);
4283 sortcv_xsub(pTHXo_ SV *a, SV *b)
4286 I32 oldsaveix = PL_savestack_ix;
4287 I32 oldscopeix = PL_scopestack_ix;
4289 CV *cv=(CV*)PL_sortcop;
4297 (void)(*CvXSUB(cv))(aTHXo_ cv);
4298 if (PL_stack_sp != PL_stack_base + 1)
4299 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4300 if (!SvNIOKp(*PL_stack_sp))
4301 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4302 result = SvIV(*PL_stack_sp);
4303 while (PL_scopestack_ix > oldscopeix) {
4306 leave_scope(oldsaveix);
4312 sv_ncmp(pTHXo_ SV *a, SV *b)
4316 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4320 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4324 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4326 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4328 if (PL_amagic_generation) { \
4329 if (SvAMAGIC(left)||SvAMAGIC(right))\
4330 *svp = amagic_call(left, \
4338 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4341 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4346 I32 i = SvIVX(tmpsv);
4356 return sv_ncmp(aTHXo_ a, b);
4360 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4363 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4368 I32 i = SvIVX(tmpsv);
4378 return sv_i_ncmp(aTHXo_ a, b);
4382 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4385 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4390 I32 i = SvIVX(tmpsv);
4400 return sv_cmp(str1, str2);
4404 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4407 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4412 I32 i = SvIVX(tmpsv);
4422 return sv_cmp_locale(str1, str2);
4426 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4428 SV *datasv = FILTER_DATA(idx);
4429 int filter_has_file = IoLINES(datasv);
4430 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4431 SV *filter_state = (SV *)IoTOP_GV(datasv);
4432 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4435 /* I was having segfault trouble under Linux 2.2.5 after a
4436 parse error occured. (Had to hack around it with a test
4437 for PL_error_count == 0.) Solaris doesn't segfault --
4438 not sure where the trouble is yet. XXX */
4440 if (filter_has_file) {
4441 len = FILTER_READ(idx+1, buf_sv, maxlen);
4444 if (filter_sub && len >= 0) {
4455 PUSHs(sv_2mortal(newSViv(maxlen)));
4457 PUSHs(filter_state);
4460 count = call_sv(filter_sub, G_SCALAR);
4476 IoLINES(datasv) = 0;
4477 if (filter_child_proc) {
4478 SvREFCNT_dec(filter_child_proc);
4479 IoFMT_GV(datasv) = Nullgv;
4482 SvREFCNT_dec(filter_state);
4483 IoTOP_GV(datasv) = Nullgv;
4486 SvREFCNT_dec(filter_sub);
4487 IoBOTTOM_GV(datasv) = Nullgv;
4489 filter_del(run_user_filter);
4498 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4500 return sv_cmp_locale(str1, str2);
4504 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4506 return sv_cmp(str1, str2);
4509 #endif /* PERL_OBJECT */