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 */
118 pm->op_pmdynflags |= PMdf_UTF8;
119 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
120 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
121 inside tie/overload accessors. */
125 #ifndef INCOMPLETE_TAINTS
128 pm->op_pmdynflags |= PMdf_TAINTED;
130 pm->op_pmdynflags &= ~PMdf_TAINTED;
134 if (!pm->op_pmregexp->prelen && PL_curpm)
136 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
137 pm->op_pmflags |= PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
161 rxres_restore(&cx->sb_rxres, rx);
163 if (cx->sb_iters++) {
164 if (cx->sb_iters > cx->sb_maxiters)
165 DIE(aTHX_ "Substitution loop");
167 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
168 cx->sb_rxtainted |= 2;
169 sv_catsv(dstr, POPs);
172 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
173 s == m, cx->sb_targ, NULL,
174 ((cx->sb_rflags & REXEC_COPY_STR)
175 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
176 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
178 SV *targ = cx->sb_targ;
179 sv_catpvn(dstr, s, cx->sb_strend - s);
181 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183 (void)SvOOK_off(targ);
184 Safefree(SvPVX(targ));
185 SvPVX(targ) = SvPVX(dstr);
186 SvCUR_set(targ, SvCUR(dstr));
187 SvLEN_set(targ, SvLEN(dstr));
191 TAINT_IF(cx->sb_rxtainted & 1);
192 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
194 (void)SvPOK_only(targ);
195 TAINT_IF(cx->sb_rxtainted);
199 LEAVE_SCOPE(cx->sb_oldsave);
201 RETURNOP(pm->op_next);
204 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
207 cx->sb_orig = orig = rx->subbeg;
209 cx->sb_strend = s + (cx->sb_strend - m);
211 cx->sb_m = m = rx->startp[0] + orig;
212 sv_catpvn(dstr, s, m-s);
213 cx->sb_s = rx->endp[0] + orig;
214 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
215 rxres_save(&cx->sb_rxres, rx);
216 RETURNOP(pm->op_pmreplstart);
220 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
225 if (!p || p[1] < rx->nparens) {
226 i = 6 + rx->nparens * 2;
234 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
235 RX_MATCH_COPIED_off(rx);
239 *p++ = PTR2UV(rx->subbeg);
240 *p++ = (UV)rx->sublen;
241 for (i = 0; i <= rx->nparens; ++i) {
242 *p++ = (UV)rx->startp[i];
243 *p++ = (UV)rx->endp[i];
248 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
253 if (RX_MATCH_COPIED(rx))
254 Safefree(rx->subbeg);
255 RX_MATCH_COPIED_set(rx, *p);
260 rx->subbeg = INT2PTR(char*,*p++);
261 rx->sublen = (I32)(*p++);
262 for (i = 0; i <= rx->nparens; ++i) {
263 rx->startp[i] = (I32)(*p++);
264 rx->endp[i] = (I32)(*p++);
269 Perl_rxres_free(pTHX_ void **rsp)
274 Safefree(INT2PTR(char*,*p));
282 djSP; dMARK; dORIGMARK;
283 register SV *tmpForm = *++MARK;
295 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
301 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
302 bool item_is_utf = FALSE;
304 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
305 SvREADONLY_off(tmpForm);
306 doparseform(tmpForm);
309 SvPV_force(PL_formtarget, len);
310 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
312 f = SvPV(tmpForm, len);
313 /* need to jump to the next word */
314 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
323 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
324 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
325 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
326 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
327 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
329 case FF_CHECKNL: name = "CHECKNL"; break;
330 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
331 case FF_SPACE: name = "SPACE"; break;
332 case FF_HALFSPACE: name = "HALFSPACE"; break;
333 case FF_ITEM: name = "ITEM"; break;
334 case FF_CHOP: name = "CHOP"; break;
335 case FF_LINEGLOB: name = "LINEGLOB"; break;
336 case FF_NEWLINE: name = "NEWLINE"; break;
337 case FF_MORE: name = "MORE"; break;
338 case FF_LINEMARK: name = "LINEMARK"; break;
339 case FF_END: name = "END"; break;
342 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
344 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
372 if (ckWARN(WARN_SYNTAX))
373 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
378 item = s = SvPV(sv, len);
381 itemsize = sv_len_utf8(sv);
382 if (itemsize != len) {
384 if (itemsize > fieldsize) {
385 itemsize = fieldsize;
386 itembytes = itemsize;
387 sv_pos_u2b(sv, &itembytes, 0);
391 send = chophere = s + itembytes;
401 sv_pos_b2u(sv, &itemsize);
406 if (itemsize > fieldsize)
407 itemsize = fieldsize;
408 send = chophere = s + itemsize;
420 item = s = SvPV(sv, len);
423 itemsize = sv_len_utf8(sv);
424 if (itemsize != len) {
426 if (itemsize <= fieldsize) {
427 send = chophere = s + itemsize;
438 itemsize = fieldsize;
439 itembytes = itemsize;
440 sv_pos_u2b(sv, &itembytes, 0);
441 send = chophere = s + itembytes;
442 while (s < send || (s == send && isSPACE(*s))) {
452 if (strchr(PL_chopset, *s))
457 itemsize = chophere - item;
458 sv_pos_b2u(sv, &itemsize);
465 if (itemsize <= fieldsize) {
466 send = chophere = s + itemsize;
477 itemsize = fieldsize;
478 send = chophere = s + itemsize;
479 while (s < send || (s == send && isSPACE(*s))) {
489 if (strchr(PL_chopset, *s))
494 itemsize = chophere - item;
499 arg = fieldsize - itemsize;
508 arg = fieldsize - itemsize;
523 switch (UTF8SKIP(s)) {
534 if ( !((*t++ = *s++) & ~31) )
542 int ch = *t++ = *s++;
545 if ( !((*t++ = *s++) & ~31) )
554 while (*s && isSPACE(*s))
561 item = s = SvPV(sv, len);
563 item_is_utf = FALSE; /* XXX is this correct? */
575 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
576 sv_catpvn(PL_formtarget, item, itemsize);
577 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
578 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
583 /* If the field is marked with ^ and the value is undefined,
586 if ((arg & 512) && !SvOK(sv)) {
594 /* Formats aren't yet marked for locales, so assume "yes". */
596 RESTORE_NUMERIC_LOCAL();
597 #if defined(USE_LONG_DOUBLE)
599 sprintf(t, "%#*.*" PERL_PRIfldbl,
600 (int) fieldsize, (int) arg & 255, value);
602 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
607 (int) fieldsize, (int) arg & 255, value);
610 (int) fieldsize, value);
613 RESTORE_NUMERIC_STANDARD();
620 while (t-- > linemark && *t == ' ') ;
628 if (arg) { /* repeat until fields exhausted? */
630 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
631 lines += FmLINES(PL_formtarget);
634 if (strnEQ(linemark, linemark - arg, arg))
635 DIE(aTHX_ "Runaway format");
637 FmLINES(PL_formtarget) = lines;
639 RETURNOP(cLISTOP->op_first);
652 while (*s && isSPACE(*s) && s < send)
656 arg = fieldsize - itemsize;
663 if (strnEQ(s," ",3)) {
664 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
675 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
676 FmLINES(PL_formtarget) += lines;
688 if (PL_stack_base + *PL_markstack_ptr == SP) {
690 if (GIMME_V == G_SCALAR)
691 XPUSHs(sv_2mortal(newSViv(0)));
692 RETURNOP(PL_op->op_next->op_next);
694 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
695 pp_pushmark(); /* push dst */
696 pp_pushmark(); /* push src */
697 ENTER; /* enter outer scope */
700 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
702 ENTER; /* enter inner scope */
705 src = PL_stack_base[*PL_markstack_ptr];
710 if (PL_op->op_type == OP_MAPSTART)
711 pp_pushmark(); /* push top */
712 return ((LOGOP*)PL_op->op_next)->op_other;
717 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
723 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
729 ++PL_markstack_ptr[-1];
731 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
732 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
733 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
738 PL_markstack_ptr[-1] += shift;
739 *PL_markstack_ptr += shift;
743 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
746 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
748 LEAVE; /* exit inner scope */
751 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
755 (void)POPMARK; /* pop top */
756 LEAVE; /* exit outer scope */
757 (void)POPMARK; /* pop src */
758 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
759 (void)POPMARK; /* pop dst */
760 SP = PL_stack_base + POPMARK; /* pop original mark */
761 if (gimme == G_SCALAR) {
765 else if (gimme == G_ARRAY)
772 ENTER; /* enter inner scope */
775 src = PL_stack_base[PL_markstack_ptr[-1]];
779 RETURNOP(cLOGOP->op_other);
785 djSP; dMARK; dORIGMARK;
787 SV **myorigmark = ORIGMARK;
793 OP* nextop = PL_op->op_next;
795 bool hasargs = FALSE;
798 if (gimme != G_ARRAY) {
804 SAVEVPTR(PL_sortcop);
805 if (PL_op->op_flags & OPf_STACKED) {
806 if (PL_op->op_flags & OPf_SPECIAL) {
807 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
808 kid = kUNOP->op_first; /* pass rv2gv */
809 kid = kUNOP->op_first; /* pass leave */
810 PL_sortcop = kid->op_next;
811 stash = CopSTASH(PL_curcop);
814 cv = sv_2cv(*++MARK, &stash, &gv, 0);
815 if (cv && SvPOK(cv)) {
817 char *proto = SvPV((SV*)cv, n_a);
818 if (proto && strEQ(proto, "$$")) {
822 if (!(cv && CvROOT(cv))) {
823 if (cv && CvXSUB(cv)) {
827 SV *tmpstr = sv_newmortal();
828 gv_efullname3(tmpstr, gv, Nullch);
829 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
833 DIE(aTHX_ "Undefined subroutine in sort");
838 PL_sortcop = (OP*)cv;
840 PL_sortcop = CvSTART(cv);
841 SAVEVPTR(CvROOT(cv)->op_ppaddr);
842 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
845 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
851 stash = CopSTASH(PL_curcop);
855 while (MARK < SP) { /* This may or may not shift down one here. */
857 if (*up = *++MARK) { /* Weed out nulls. */
859 if (!PL_sortcop && !SvPOK(*up)) {
864 (void)sv_2pv(*up, &n_a);
869 max = --up - myorigmark;
874 bool oldcatch = CATCH_GET;
880 PUSHSTACKi(PERLSI_SORT);
881 if (PL_sortstash != stash) {
882 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
883 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
884 PL_sortstash = stash;
887 SAVESPTR(GvSV(PL_firstgv));
888 SAVESPTR(GvSV(PL_secondgv));
890 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
891 if (!(PL_op->op_flags & OPf_SPECIAL)) {
892 cx->cx_type = CXt_SUB;
893 cx->blk_gimme = G_SCALAR;
896 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
898 PL_sortcxix = cxstack_ix;
900 if (hasargs && !is_xsub) {
901 /* This is mostly copied from pp_entersub */
902 AV *av = (AV*)PL_curpad[0];
905 cx->blk_sub.savearray = GvAV(PL_defgv);
906 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
907 #endif /* USE_THREADS */
908 cx->blk_sub.argarray = av;
910 qsortsv((myorigmark+1), max,
911 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
913 POPBLOCK(cx,PL_curpm);
921 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
922 qsortsv(ORIGMARK+1, max,
923 (PL_op->op_private & OPpSORT_NUMERIC)
924 ? ( (PL_op->op_private & OPpSORT_INTEGER)
925 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
926 : ( overloading ? amagic_ncmp : sv_ncmp))
927 : ( (PL_op->op_private & OPpLOCALE)
930 : sv_cmp_locale_static)
931 : ( overloading ? amagic_cmp : sv_cmp_static)));
932 if (PL_op->op_private & OPpSORT_REVERSE) {
934 SV **q = ORIGMARK+max;
944 PL_stack_sp = ORIGMARK + max;
952 if (GIMME == G_ARRAY)
954 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
955 return cLOGOP->op_other;
964 if (GIMME == G_ARRAY) {
965 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
969 SV *targ = PAD_SV(PL_op->op_targ);
971 if ((PL_op->op_private & OPpFLIP_LINENUM)
972 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
974 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
975 if (PL_op->op_flags & OPf_SPECIAL) {
983 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
996 if (GIMME == G_ARRAY) {
1002 if (SvGMAGICAL(left))
1004 if (SvGMAGICAL(right))
1007 if (SvNIOKp(left) || !SvPOKp(left) ||
1008 SvNIOKp(right) || !SvPOKp(right) ||
1009 (looks_like_number(left) && *SvPVX(left) != '0' &&
1010 looks_like_number(right) && *SvPVX(right) != '0'))
1012 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1013 DIE(aTHX_ "Range iterator outside integer range");
1024 sv = sv_2mortal(newSViv(i++));
1029 SV *final = sv_mortalcopy(right);
1031 char *tmps = SvPV(final, len);
1033 sv = sv_mortalcopy(left);
1035 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1037 if (strEQ(SvPVX(sv),tmps))
1039 sv = sv_2mortal(newSVsv(sv));
1046 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1048 if ((PL_op->op_private & OPpFLIP_LINENUM)
1049 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1051 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1052 sv_catpv(targ, "E0");
1063 S_dopoptolabel(pTHX_ char *label)
1067 register PERL_CONTEXT *cx;
1069 for (i = cxstack_ix; i >= 0; i--) {
1071 switch (CxTYPE(cx)) {
1073 if (ckWARN(WARN_UNSAFE))
1074 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1075 PL_op_name[PL_op->op_type]);
1078 if (ckWARN(WARN_UNSAFE))
1079 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1080 PL_op_name[PL_op->op_type]);
1083 if (ckWARN(WARN_UNSAFE))
1084 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1085 PL_op_name[PL_op->op_type]);
1088 if (ckWARN(WARN_UNSAFE))
1089 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1090 PL_op_name[PL_op->op_type]);
1093 if (ckWARN(WARN_UNSAFE))
1094 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1095 PL_op_name[PL_op->op_type]);
1098 if (!cx->blk_loop.label ||
1099 strNE(label, cx->blk_loop.label) ) {
1100 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1101 (long)i, cx->blk_loop.label));
1104 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1112 Perl_dowantarray(pTHX)
1114 I32 gimme = block_gimme();
1115 return (gimme == G_VOID) ? G_SCALAR : gimme;
1119 Perl_block_gimme(pTHX)
1124 cxix = dopoptosub(cxstack_ix);
1128 switch (cxstack[cxix].blk_gimme) {
1136 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1143 S_dopoptosub(pTHX_ I32 startingblock)
1146 return dopoptosub_at(cxstack, startingblock);
1150 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1154 register PERL_CONTEXT *cx;
1155 for (i = startingblock; i >= 0; i--) {
1157 switch (CxTYPE(cx)) {
1163 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1171 S_dopoptoeval(pTHX_ I32 startingblock)
1175 register PERL_CONTEXT *cx;
1176 for (i = startingblock; i >= 0; i--) {
1178 switch (CxTYPE(cx)) {
1182 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1190 S_dopoptoloop(pTHX_ I32 startingblock)
1194 register PERL_CONTEXT *cx;
1195 for (i = startingblock; i >= 0; i--) {
1197 switch (CxTYPE(cx)) {
1199 if (ckWARN(WARN_UNSAFE))
1200 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
1201 PL_op_name[PL_op->op_type]);
1204 if (ckWARN(WARN_UNSAFE))
1205 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
1206 PL_op_name[PL_op->op_type]);
1209 if (ckWARN(WARN_UNSAFE))
1210 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1211 PL_op_name[PL_op->op_type]);
1214 if (ckWARN(WARN_UNSAFE))
1215 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
1216 PL_op_name[PL_op->op_type]);
1219 if (ckWARN(WARN_UNSAFE))
1220 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
1221 PL_op_name[PL_op->op_type]);
1224 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1232 Perl_dounwind(pTHX_ I32 cxix)
1235 register PERL_CONTEXT *cx;
1239 while (cxstack_ix > cxix) {
1241 cx = &cxstack[cxstack_ix];
1242 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1243 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1244 /* Note: we don't need to restore the base context info till the end. */
1245 switch (CxTYPE(cx)) {
1248 continue; /* not break */
1270 * Closures mentioned at top level of eval cannot be referenced
1271 * again, and their presence indirectly causes a memory leak.
1272 * (Note that the fact that compcv and friends are still set here
1273 * is, AFAIK, an accident.) --Chip
1275 * XXX need to get comppad et al from eval's cv rather than
1276 * relying on the incidental global values.
1279 S_free_closures(pTHX)
1282 SV **svp = AvARRAY(PL_comppad_name);
1284 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1286 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1288 svp[ix] = &PL_sv_undef;
1292 SvREFCNT_dec(CvOUTSIDE(sv));
1293 CvOUTSIDE(sv) = Nullcv;
1306 Perl_qerror(pTHX_ SV *err)
1309 sv_catsv(ERRSV, err);
1311 sv_catsv(PL_errors, err);
1313 Perl_warn(aTHX_ "%"SVf, err);
1318 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1324 register PERL_CONTEXT *cx;
1329 if (PL_in_eval & EVAL_KEEPERR) {
1330 static char prefix[] = "\t(in cleanup) ";
1335 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1338 if (*e != *message || strNE(e,message))
1342 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1343 sv_catpvn(err, prefix, sizeof(prefix)-1);
1344 sv_catpvn(err, message, msglen);
1345 if (ckWARN(WARN_UNSAFE)) {
1346 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1347 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
1352 sv_setpvn(ERRSV, message, msglen);
1355 message = SvPVx(ERRSV, msglen);
1357 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1358 && PL_curstackinfo->si_prev)
1367 if (cxix < cxstack_ix)
1370 POPBLOCK(cx,PL_curpm);
1371 if (CxTYPE(cx) != CXt_EVAL) {
1372 PerlIO_write(Perl_error_log, "panic: die ", 11);
1373 PerlIO_write(Perl_error_log, message, msglen);
1378 if (gimme == G_SCALAR)
1379 *++newsp = &PL_sv_undef;
1380 PL_stack_sp = newsp;
1384 if (optype == OP_REQUIRE) {
1385 char* msg = SvPVx(ERRSV, n_a);
1386 DIE(aTHX_ "%sCompilation failed in require",
1387 *msg ? msg : "Unknown error\n");
1389 return pop_return();
1393 message = SvPVx(ERRSV, msglen);
1396 /* SFIO can really mess with your errno */
1399 PerlIO *serr = Perl_error_log;
1401 PerlIO_write(serr, message, msglen);
1402 (void)PerlIO_flush(serr);
1415 if (SvTRUE(left) != SvTRUE(right))
1427 RETURNOP(cLOGOP->op_other);
1436 RETURNOP(cLOGOP->op_other);
1442 register I32 cxix = dopoptosub(cxstack_ix);
1443 register PERL_CONTEXT *cx;
1444 register PERL_CONTEXT *ccstack = cxstack;
1445 PERL_SI *top_si = PL_curstackinfo;
1456 /* we may be in a higher stacklevel, so dig down deeper */
1457 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1458 top_si = top_si->si_prev;
1459 ccstack = top_si->si_cxstack;
1460 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1463 if (GIMME != G_ARRAY)
1467 if (PL_DBsub && cxix >= 0 &&
1468 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1472 cxix = dopoptosub_at(ccstack, cxix - 1);
1475 cx = &ccstack[cxix];
1476 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1477 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1478 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1479 field below is defined for any cx. */
1480 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1481 cx = &ccstack[dbcxix];
1484 stashname = CopSTASHPV(cx->blk_oldcop);
1485 if (GIMME != G_ARRAY) {
1487 PUSHs(&PL_sv_undef);
1490 sv_setpv(TARG, stashname);
1497 PUSHs(&PL_sv_undef);
1499 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1500 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1501 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1504 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1505 /* So is ccstack[dbcxix]. */
1507 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1508 PUSHs(sv_2mortal(sv));
1509 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1512 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1513 PUSHs(sv_2mortal(newSViv(0)));
1515 gimme = (I32)cx->blk_gimme;
1516 if (gimme == G_VOID)
1517 PUSHs(&PL_sv_undef);
1519 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1520 if (CxTYPE(cx) == CXt_EVAL) {
1521 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1522 PUSHs(cx->blk_eval.cur_text);
1525 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1526 /* Require, put the name. */
1527 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1532 PUSHs(&PL_sv_undef);
1533 PUSHs(&PL_sv_undef);
1535 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1536 && CopSTASH_eq(PL_curcop, PL_debstash))
1538 AV *ary = cx->blk_sub.argarray;
1539 int off = AvARRAY(ary) - AvALLOC(ary);
1543 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1546 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1549 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1550 av_extend(PL_dbargs, AvFILLp(ary) + off);
1551 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1552 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1554 /* XXX only hints propagated via op_private are currently
1555 * visible (others are not easily accessible, since they
1556 * use the global PL_hints) */
1557 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1558 HINT_PRIVATE_MASK)));
1572 sv_reset(tmps, CopSTASH(PL_curcop));
1584 PL_curcop = (COP*)PL_op;
1585 TAINT_NOT; /* Each statement is presumed innocent */
1586 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1589 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1593 register PERL_CONTEXT *cx;
1594 I32 gimme = G_ARRAY;
1601 DIE(aTHX_ "No DB::DB routine defined");
1603 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1615 push_return(PL_op->op_next);
1616 PUSHBLOCK(cx, CXt_SUB, SP);
1619 (void)SvREFCNT_inc(cv);
1620 SAVEVPTR(PL_curpad);
1621 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1622 RETURNOP(CvSTART(cv));
1636 register PERL_CONTEXT *cx;
1637 I32 gimme = GIMME_V;
1639 U32 cxtype = CXt_LOOP;
1648 if (PL_op->op_flags & OPf_SPECIAL) {
1650 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1651 SAVEGENERICSV(*svp);
1655 #endif /* USE_THREADS */
1656 if (PL_op->op_targ) {
1657 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1660 iterdata = (void*)PL_op->op_targ;
1661 cxtype |= CXp_PADVAR;
1666 svp = &GvSV(gv); /* symbol table variable */
1667 SAVEGENERICSV(*svp);
1670 iterdata = (void*)gv;
1676 PUSHBLOCK(cx, cxtype, SP);
1678 PUSHLOOP(cx, iterdata, MARK);
1680 PUSHLOOP(cx, svp, MARK);
1682 if (PL_op->op_flags & OPf_STACKED) {
1683 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1684 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1686 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1687 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1688 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1689 looks_like_number((SV*)cx->blk_loop.iterary) &&
1690 *SvPVX(cx->blk_loop.iterary) != '0'))
1692 if (SvNV(sv) < IV_MIN ||
1693 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1694 DIE(aTHX_ "Range iterator outside integer range");
1695 cx->blk_loop.iterix = SvIV(sv);
1696 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1699 cx->blk_loop.iterlval = newSVsv(sv);
1703 cx->blk_loop.iterary = PL_curstack;
1704 AvFILLp(PL_curstack) = SP - PL_stack_base;
1705 cx->blk_loop.iterix = MARK - PL_stack_base;
1714 register PERL_CONTEXT *cx;
1715 I32 gimme = GIMME_V;
1721 PUSHBLOCK(cx, CXt_LOOP, SP);
1722 PUSHLOOP(cx, 0, SP);
1730 register PERL_CONTEXT *cx;
1738 newsp = PL_stack_base + cx->blk_loop.resetsp;
1741 if (gimme == G_VOID)
1743 else if (gimme == G_SCALAR) {
1745 *++newsp = sv_mortalcopy(*SP);
1747 *++newsp = &PL_sv_undef;
1751 *++newsp = sv_mortalcopy(*++mark);
1752 TAINT_NOT; /* Each item is independent */
1758 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1759 PL_curpm = newpm; /* ... and pop $1 et al */
1771 register PERL_CONTEXT *cx;
1772 bool popsub2 = FALSE;
1779 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1780 if (cxstack_ix == PL_sortcxix
1781 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1783 if (cxstack_ix > PL_sortcxix)
1784 dounwind(PL_sortcxix);
1785 AvARRAY(PL_curstack)[1] = *SP;
1786 PL_stack_sp = PL_stack_base + 1;
1791 cxix = dopoptosub(cxstack_ix);
1793 DIE(aTHX_ "Can't return outside a subroutine");
1794 if (cxix < cxstack_ix)
1798 switch (CxTYPE(cx)) {
1804 if (AvFILLp(PL_comppad_name) >= 0)
1807 if (optype == OP_REQUIRE &&
1808 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1810 /* Unassume the success we assumed earlier. */
1811 char *name = cx->blk_eval.old_name;
1812 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1813 DIE(aTHX_ "%s did not return a true value", name);
1820 DIE(aTHX_ "panic: return");
1824 if (gimme == G_SCALAR) {
1827 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1829 *++newsp = SvREFCNT_inc(*SP);
1834 *++newsp = sv_mortalcopy(*SP);
1837 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1839 *++newsp = sv_mortalcopy(*SP);
1841 *++newsp = &PL_sv_undef;
1843 else if (gimme == G_ARRAY) {
1844 while (++MARK <= SP) {
1845 *++newsp = (popsub2 && SvTEMP(*MARK))
1846 ? *MARK : sv_mortalcopy(*MARK);
1847 TAINT_NOT; /* Each item is independent */
1850 PL_stack_sp = newsp;
1852 /* Stack values are safe: */
1854 POPSUB(cx,sv); /* release CV and @_ ... */
1858 PL_curpm = newpm; /* ... and pop $1 et al */
1862 return pop_return();
1869 register PERL_CONTEXT *cx;
1879 if (PL_op->op_flags & OPf_SPECIAL) {
1880 cxix = dopoptoloop(cxstack_ix);
1882 DIE(aTHX_ "Can't \"last\" outside a loop block");
1885 cxix = dopoptolabel(cPVOP->op_pv);
1887 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1889 if (cxix < cxstack_ix)
1894 switch (CxTYPE(cx)) {
1897 newsp = PL_stack_base + cx->blk_loop.resetsp;
1898 nextop = cx->blk_loop.last_op->op_next;
1902 nextop = pop_return();
1906 nextop = pop_return();
1910 nextop = pop_return();
1913 DIE(aTHX_ "panic: last");
1917 if (gimme == G_SCALAR) {
1919 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1920 ? *SP : sv_mortalcopy(*SP);
1922 *++newsp = &PL_sv_undef;
1924 else if (gimme == G_ARRAY) {
1925 while (++MARK <= SP) {
1926 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1927 ? *MARK : sv_mortalcopy(*MARK);
1928 TAINT_NOT; /* Each item is independent */
1934 /* Stack values are safe: */
1937 POPLOOP(cx); /* release loop vars ... */
1941 POPSUB(cx,sv); /* release CV and @_ ... */
1944 PL_curpm = newpm; /* ... and pop $1 et al */
1954 register PERL_CONTEXT *cx;
1957 if (PL_op->op_flags & OPf_SPECIAL) {
1958 cxix = dopoptoloop(cxstack_ix);
1960 DIE(aTHX_ "Can't \"next\" outside a loop block");
1963 cxix = dopoptolabel(cPVOP->op_pv);
1965 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1967 if (cxix < cxstack_ix)
1970 cx = &cxstack[cxstack_ix];
1972 OP *nextop = cx->blk_loop.next_op;
1973 /* clean scope, but only if there's no continue block */
1974 if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) {
1976 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1977 LEAVE_SCOPE(oldsave);
1986 register PERL_CONTEXT *cx;
1989 if (PL_op->op_flags & OPf_SPECIAL) {
1990 cxix = dopoptoloop(cxstack_ix);
1992 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1995 cxix = dopoptolabel(cPVOP->op_pv);
1997 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1999 if (cxix < cxstack_ix)
2003 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2004 LEAVE_SCOPE(oldsave);
2005 return cx->blk_loop.redo_op;
2009 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2013 static char too_deep[] = "Target of goto is too deeply nested";
2016 Perl_croak(aTHX_ too_deep);
2017 if (o->op_type == OP_LEAVE ||
2018 o->op_type == OP_SCOPE ||
2019 o->op_type == OP_LEAVELOOP ||
2020 o->op_type == OP_LEAVETRY)
2022 *ops++ = cUNOPo->op_first;
2024 Perl_croak(aTHX_ too_deep);
2027 if (o->op_flags & OPf_KIDS) {
2029 /* First try all the kids at this level, since that's likeliest. */
2030 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2031 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2032 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2035 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2036 if (kid == PL_lastgotoprobe)
2038 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2040 (ops[-1]->op_type != OP_NEXTSTATE &&
2041 ops[-1]->op_type != OP_DBSTATE)))
2043 if (o = dofindlabel(kid, label, ops, oplimit))
2062 register PERL_CONTEXT *cx;
2063 #define GOTO_DEPTH 64
2064 OP *enterops[GOTO_DEPTH];
2066 int do_dump = (PL_op->op_type == OP_DUMP);
2067 static char must_have_label[] = "goto must have label";
2070 if (PL_op->op_flags & OPf_STACKED) {
2074 /* This egregious kludge implements goto &subroutine */
2075 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2077 register PERL_CONTEXT *cx;
2078 CV* cv = (CV*)SvRV(sv);
2084 if (!CvROOT(cv) && !CvXSUB(cv)) {
2089 /* autoloaded stub? */
2090 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2092 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2093 GvNAMELEN(gv), FALSE);
2094 if (autogv && (cv = GvCV(autogv)))
2096 tmpstr = sv_newmortal();
2097 gv_efullname3(tmpstr, gv, Nullch);
2098 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2100 DIE(aTHX_ "Goto undefined subroutine");
2103 /* First do some returnish stuff. */
2104 cxix = dopoptosub(cxstack_ix);
2106 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2107 if (cxix < cxstack_ix)
2110 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2111 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2113 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2114 /* put @_ back onto stack */
2115 AV* av = cx->blk_sub.argarray;
2117 items = AvFILLp(av) + 1;
2119 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2120 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2121 PL_stack_sp += items;
2123 SvREFCNT_dec(GvAV(PL_defgv));
2124 GvAV(PL_defgv) = cx->blk_sub.savearray;
2125 #endif /* USE_THREADS */
2126 /* abandon @_ if it got reified */
2128 (void)sv_2mortal((SV*)av); /* delay until return */
2130 av_extend(av, items-1);
2131 AvFLAGS(av) = AVf_REIFY;
2132 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2135 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2139 av = (AV*)PL_curpad[0];
2141 av = GvAV(PL_defgv);
2143 items = AvFILLp(av) + 1;
2145 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2146 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2147 PL_stack_sp += items;
2149 if (CxTYPE(cx) == CXt_SUB &&
2150 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2151 SvREFCNT_dec(cx->blk_sub.cv);
2152 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2153 LEAVE_SCOPE(oldsave);
2155 /* Now do some callish stuff. */
2158 #ifdef PERL_XSUB_OLDSTYLE
2159 if (CvOLDSTYLE(cv)) {
2160 I32 (*fp3)(int,int,int);
2165 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2166 items = (*fp3)(CvXSUBANY(cv).any_i32,
2167 mark - PL_stack_base + 1,
2169 SP = PL_stack_base + items;
2172 #endif /* PERL_XSUB_OLDSTYLE */
2177 PL_stack_sp--; /* There is no cv arg. */
2178 /* Push a mark for the start of arglist */
2180 (void)(*CvXSUB(cv))(aTHXo_ cv);
2181 /* Pop the current context like a decent sub should */
2182 POPBLOCK(cx, PL_curpm);
2183 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2186 return pop_return();
2189 AV* padlist = CvPADLIST(cv);
2190 SV** svp = AvARRAY(padlist);
2191 if (CxTYPE(cx) == CXt_EVAL) {
2192 PL_in_eval = cx->blk_eval.old_in_eval;
2193 PL_eval_root = cx->blk_eval.old_eval_root;
2194 cx->cx_type = CXt_SUB;
2195 cx->blk_sub.hasargs = 0;
2197 cx->blk_sub.cv = cv;
2198 cx->blk_sub.olddepth = CvDEPTH(cv);
2200 if (CvDEPTH(cv) < 2)
2201 (void)SvREFCNT_inc(cv);
2202 else { /* save temporaries on recursion? */
2203 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2204 sub_crush_depth(cv);
2205 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2206 AV *newpad = newAV();
2207 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2208 I32 ix = AvFILLp((AV*)svp[1]);
2209 I32 names_fill = AvFILLp((AV*)svp[0]);
2210 svp = AvARRAY(svp[0]);
2211 for ( ;ix > 0; ix--) {
2212 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2213 char *name = SvPVX(svp[ix]);
2214 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2217 /* outer lexical or anon code */
2218 av_store(newpad, ix,
2219 SvREFCNT_inc(oldpad[ix]) );
2221 else { /* our own lexical */
2223 av_store(newpad, ix, sv = (SV*)newAV());
2224 else if (*name == '%')
2225 av_store(newpad, ix, sv = (SV*)newHV());
2227 av_store(newpad, ix, sv = NEWSV(0,0));
2231 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2232 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2235 av_store(newpad, ix, sv = NEWSV(0,0));
2239 if (cx->blk_sub.hasargs) {
2242 av_store(newpad, 0, (SV*)av);
2243 AvFLAGS(av) = AVf_REIFY;
2245 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2246 AvFILLp(padlist) = CvDEPTH(cv);
2247 svp = AvARRAY(padlist);
2251 if (!cx->blk_sub.hasargs) {
2252 AV* av = (AV*)PL_curpad[0];
2254 items = AvFILLp(av) + 1;
2256 /* Mark is at the end of the stack. */
2258 Copy(AvARRAY(av), SP + 1, items, SV*);
2263 #endif /* USE_THREADS */
2264 SAVEVPTR(PL_curpad);
2265 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2267 if (cx->blk_sub.hasargs)
2268 #endif /* USE_THREADS */
2270 AV* av = (AV*)PL_curpad[0];
2274 cx->blk_sub.savearray = GvAV(PL_defgv);
2275 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2276 #endif /* USE_THREADS */
2277 cx->blk_sub.argarray = av;
2280 if (items >= AvMAX(av) + 1) {
2282 if (AvARRAY(av) != ary) {
2283 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2284 SvPVX(av) = (char*)ary;
2286 if (items >= AvMAX(av) + 1) {
2287 AvMAX(av) = items - 1;
2288 Renew(ary,items+1,SV*);
2290 SvPVX(av) = (char*)ary;
2293 Copy(mark,AvARRAY(av),items,SV*);
2294 AvFILLp(av) = items - 1;
2295 assert(!AvREAL(av));
2302 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2304 * We do not care about using sv to call CV;
2305 * it's for informational purposes only.
2307 SV *sv = GvSV(PL_DBsub);
2310 if (PERLDB_SUB_NN) {
2311 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2314 gv_efullname3(sv, CvGV(cv), Nullch);
2317 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2318 PUSHMARK( PL_stack_sp );
2319 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2323 RETURNOP(CvSTART(cv));
2327 label = SvPV(sv,n_a);
2328 if (!(do_dump || *label))
2329 DIE(aTHX_ must_have_label);
2332 else if (PL_op->op_flags & OPf_SPECIAL) {
2334 DIE(aTHX_ must_have_label);
2337 label = cPVOP->op_pv;
2339 if (label && *label) {
2344 PL_lastgotoprobe = 0;
2346 for (ix = cxstack_ix; ix >= 0; ix--) {
2348 switch (CxTYPE(cx)) {
2350 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2353 gotoprobe = cx->blk_oldcop->op_sibling;
2359 gotoprobe = cx->blk_oldcop->op_sibling;
2361 gotoprobe = PL_main_root;
2364 if (CvDEPTH(cx->blk_sub.cv)) {
2365 gotoprobe = CvROOT(cx->blk_sub.cv);
2371 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2374 DIE(aTHX_ "panic: goto");
2375 gotoprobe = PL_main_root;
2378 retop = dofindlabel(gotoprobe, label,
2379 enterops, enterops + GOTO_DEPTH);
2382 PL_lastgotoprobe = gotoprobe;
2385 DIE(aTHX_ "Can't find label %s", label);
2387 /* pop unwanted frames */
2389 if (ix < cxstack_ix) {
2396 oldsave = PL_scopestack[PL_scopestack_ix];
2397 LEAVE_SCOPE(oldsave);
2400 /* push wanted frames */
2402 if (*enterops && enterops[1]) {
2404 for (ix = 1; enterops[ix]; ix++) {
2405 PL_op = enterops[ix];
2406 /* Eventually we may want to stack the needed arguments
2407 * for each op. For now, we punt on the hard ones. */
2408 if (PL_op->op_type == OP_ENTERITER)
2409 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2410 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2418 if (!retop) retop = PL_main_start;
2420 PL_restartop = retop;
2421 PL_do_undump = TRUE;
2425 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2426 PL_do_undump = FALSE;
2442 if (anum == 1 && VMSISH_EXIT)
2446 PL_exit_flags |= PERL_EXIT_EXPECTED;
2448 PUSHs(&PL_sv_undef);
2456 NV value = SvNVx(GvSV(cCOP->cop_gv));
2457 register I32 match = I_32(value);
2460 if (((NV)match) > value)
2461 --match; /* was fractional--truncate other way */
2463 match -= cCOP->uop.scop.scop_offset;
2466 else if (match > cCOP->uop.scop.scop_max)
2467 match = cCOP->uop.scop.scop_max;
2468 PL_op = cCOP->uop.scop.scop_next[match];
2478 PL_op = PL_op->op_next; /* can't assume anything */
2481 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2482 match -= cCOP->uop.scop.scop_offset;
2485 else if (match > cCOP->uop.scop.scop_max)
2486 match = cCOP->uop.scop.scop_max;
2487 PL_op = cCOP->uop.scop.scop_next[match];
2496 S_save_lines(pTHX_ AV *array, SV *sv)
2498 register char *s = SvPVX(sv);
2499 register char *send = SvPVX(sv) + SvCUR(sv);
2501 register I32 line = 1;
2503 while (s && s < send) {
2504 SV *tmpstr = NEWSV(85,0);
2506 sv_upgrade(tmpstr, SVt_PVMG);
2507 t = strchr(s, '\n');
2513 sv_setpvn(tmpstr, s, t - s);
2514 av_store(array, line++, tmpstr);
2520 S_docatch_body(pTHX_ va_list args)
2527 S_docatch(pTHX_ OP *o)
2532 volatile PERL_SI *cursi = PL_curstackinfo;
2536 assert(CATCH_GET == TRUE);
2540 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2545 if (PL_restartop && cursi == PL_curstackinfo) {
2546 PL_op = PL_restartop;
2561 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2562 /* sv Text to convert to OP tree. */
2563 /* startop op_free() this to undo. */
2564 /* code Short string id of the caller. */
2566 dSP; /* Make POPBLOCK work. */
2569 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2572 OP *oop = PL_op, *rop;
2573 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2579 /* switch to eval mode */
2581 if (PL_curcop == &PL_compiling) {
2582 SAVECOPSTASH(&PL_compiling);
2583 CopSTASH_set(&PL_compiling, PL_curstash);
2585 SAVECOPFILE(&PL_compiling);
2586 SAVECOPLINE(&PL_compiling);
2587 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2588 CopFILE_set(&PL_compiling, tmpbuf+2);
2589 CopLINE_set(&PL_compiling, 1);
2590 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2591 deleting the eval's FILEGV from the stash before gv_check() runs
2592 (i.e. before run-time proper). To work around the coredump that
2593 ensues, we always turn GvMULTI_on for any globals that were
2594 introduced within evals. See force_ident(). GSAR 96-10-12 */
2595 safestr = savepv(tmpbuf);
2596 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2598 #ifdef OP_IN_REGISTER
2606 PL_op->op_type = OP_ENTEREVAL;
2607 PL_op->op_flags = 0; /* Avoid uninit warning. */
2608 PUSHBLOCK(cx, CXt_EVAL, SP);
2609 PUSHEVAL(cx, 0, Nullgv);
2610 rop = doeval(G_SCALAR, startop);
2611 POPBLOCK(cx,PL_curpm);
2614 (*startop)->op_type = OP_NULL;
2615 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2617 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2619 if (PL_curcop == &PL_compiling)
2620 PL_compiling.op_private = PL_hints;
2621 #ifdef OP_IN_REGISTER
2627 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2629 S_doeval(pTHX_ int gimme, OP** startop)
2637 PL_in_eval = EVAL_INEVAL;
2641 /* set up a scratch pad */
2644 SAVEVPTR(PL_curpad);
2645 SAVESPTR(PL_comppad);
2646 SAVESPTR(PL_comppad_name);
2647 SAVEI32(PL_comppad_name_fill);
2648 SAVEI32(PL_min_intro_pending);
2649 SAVEI32(PL_max_intro_pending);
2652 for (i = cxstack_ix - 1; i >= 0; i--) {
2653 PERL_CONTEXT *cx = &cxstack[i];
2654 if (CxTYPE(cx) == CXt_EVAL)
2656 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2657 caller = cx->blk_sub.cv;
2662 SAVESPTR(PL_compcv);
2663 PL_compcv = (CV*)NEWSV(1104,0);
2664 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2665 CvEVAL_on(PL_compcv);
2667 CvOWNER(PL_compcv) = 0;
2668 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2669 MUTEX_INIT(CvMUTEXP(PL_compcv));
2670 #endif /* USE_THREADS */
2672 PL_comppad = newAV();
2673 av_push(PL_comppad, Nullsv);
2674 PL_curpad = AvARRAY(PL_comppad);
2675 PL_comppad_name = newAV();
2676 PL_comppad_name_fill = 0;
2677 PL_min_intro_pending = 0;
2680 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2681 PL_curpad[0] = (SV*)newAV();
2682 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2683 #endif /* USE_THREADS */
2685 comppadlist = newAV();
2686 AvREAL_off(comppadlist);
2687 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2688 av_store(comppadlist, 1, (SV*)PL_comppad);
2689 CvPADLIST(PL_compcv) = comppadlist;
2691 if (!saveop || saveop->op_type != OP_REQUIRE)
2692 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2694 SAVEFREESV(PL_compcv);
2696 /* make sure we compile in the right package */
2698 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2699 SAVESPTR(PL_curstash);
2700 PL_curstash = CopSTASH(PL_curcop);
2702 SAVESPTR(PL_beginav);
2703 PL_beginav = newAV();
2704 SAVEFREESV(PL_beginav);
2706 /* try to compile it */
2708 PL_eval_root = Nullop;
2710 PL_curcop = &PL_compiling;
2711 PL_curcop->cop_arybase = 0;
2712 SvREFCNT_dec(PL_rs);
2713 PL_rs = newSVpvn("\n", 1);
2714 if (saveop && saveop->op_flags & OPf_SPECIAL)
2715 PL_in_eval |= EVAL_KEEPERR;
2718 if (yyparse() || PL_error_count || !PL_eval_root) {
2722 I32 optype = 0; /* Might be reset by POPEVAL. */
2727 op_free(PL_eval_root);
2728 PL_eval_root = Nullop;
2730 SP = PL_stack_base + POPMARK; /* pop original mark */
2732 POPBLOCK(cx,PL_curpm);
2738 if (optype == OP_REQUIRE) {
2739 char* msg = SvPVx(ERRSV, n_a);
2740 DIE(aTHX_ "%sCompilation failed in require",
2741 *msg ? msg : "Unknown error\n");
2744 char* msg = SvPVx(ERRSV, n_a);
2746 POPBLOCK(cx,PL_curpm);
2748 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2749 (*msg ? msg : "Unknown error\n"));
2751 SvREFCNT_dec(PL_rs);
2752 PL_rs = SvREFCNT_inc(PL_nrs);
2754 MUTEX_LOCK(&PL_eval_mutex);
2756 COND_SIGNAL(&PL_eval_cond);
2757 MUTEX_UNLOCK(&PL_eval_mutex);
2758 #endif /* USE_THREADS */
2761 SvREFCNT_dec(PL_rs);
2762 PL_rs = SvREFCNT_inc(PL_nrs);
2763 CopLINE_set(&PL_compiling, 0);
2765 *startop = PL_eval_root;
2766 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2767 CvOUTSIDE(PL_compcv) = Nullcv;
2769 SAVEFREEOP(PL_eval_root);
2771 scalarvoid(PL_eval_root);
2772 else if (gimme & G_ARRAY)
2775 scalar(PL_eval_root);
2777 DEBUG_x(dump_eval());
2779 /* Register with debugger: */
2780 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2781 CV *cv = get_cv("DB::postponed", FALSE);
2785 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2787 call_sv((SV*)cv, G_DISCARD);
2791 /* compiled okay, so do it */
2793 CvDEPTH(PL_compcv) = 1;
2794 SP = PL_stack_base + POPMARK; /* pop original mark */
2795 PL_op = saveop; /* The caller may need it. */
2797 MUTEX_LOCK(&PL_eval_mutex);
2799 COND_SIGNAL(&PL_eval_cond);
2800 MUTEX_UNLOCK(&PL_eval_mutex);
2801 #endif /* USE_THREADS */
2803 RETURNOP(PL_eval_start);
2807 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2809 STRLEN namelen = strlen(name);
2812 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2813 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2814 char *pmc = SvPV_nolen(pmcsv);
2817 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2818 fp = PerlIO_open(name, mode);
2821 if (PerlLIO_stat(name, &pmstat) < 0 ||
2822 pmstat.st_mtime < pmcstat.st_mtime)
2824 fp = PerlIO_open(pmc, mode);
2827 fp = PerlIO_open(name, mode);
2830 SvREFCNT_dec(pmcsv);
2833 fp = PerlIO_open(name, mode);
2841 register PERL_CONTEXT *cx;
2846 SV *namesv = Nullsv;
2848 I32 gimme = G_SCALAR;
2849 PerlIO *tryrsfp = 0;
2851 int filter_has_file = 0;
2852 GV *filter_child_proc = 0;
2853 SV *filter_state = 0;
2859 if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */
2861 U8 *s = (U8*)SvPVX(sv);
2862 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2864 rev = utf8_to_uv(s, &len);
2867 ver = utf8_to_uv(s, &len);
2870 sver = utf8_to_uv(s, &len);
2879 if (PERL_REVISION < rev
2880 || (PERL_REVISION == rev
2881 && (PERL_VERSION < ver
2882 || (PERL_VERSION == ver
2883 && PERL_SUBVERSION < sver))))
2885 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2886 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2887 PERL_VERSION, PERL_SUBVERSION);
2890 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2893 ver = (UV)((n-rev)*1000);
2894 sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2896 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2897 + ((NV)PERL_SUBVERSION/(NV)1000000)
2898 + 0.00000099 < SvNV(sv))
2900 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2901 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2902 PERL_VERSION, PERL_SUBVERSION);
2907 name = SvPV(sv, len);
2908 if (!(name && len > 0 && *name))
2909 DIE(aTHX_ "Null filename used");
2910 TAINT_PROPER("require");
2911 if (PL_op->op_type == OP_REQUIRE &&
2912 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2913 *svp != &PL_sv_undef)
2916 /* prepare to compile file */
2918 if (PERL_FILE_IS_ABSOLUTE(name)
2919 || (*name == '.' && (name[1] == '/' ||
2920 (name[1] == '.' && name[2] == '/'))))
2923 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2926 AV *ar = GvAVn(PL_incgv);
2930 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2933 namesv = NEWSV(806, 0);
2934 for (i = 0; i <= AvFILL(ar); i++) {
2935 SV *dirsv = *av_fetch(ar, i, TRUE);
2941 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2942 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2945 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2946 PTR2UV(SvANY(loader)), name);
2947 tryname = SvPVX(namesv);
2958 count = call_sv(loader, G_ARRAY);
2968 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2972 if (SvTYPE(arg) == SVt_PVGV) {
2973 IO *io = GvIO((GV *)arg);
2978 tryrsfp = IoIFP(io);
2979 if (IoTYPE(io) == '|') {
2980 /* reading from a child process doesn't
2981 nest -- when returning from reading
2982 the inner module, the outer one is
2983 unreadable (closed?) I've tried to
2984 save the gv to manage the lifespan of
2985 the pipe, but this didn't help. XXX */
2986 filter_child_proc = (GV *)arg;
2987 (void)SvREFCNT_inc(filter_child_proc);
2990 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2991 PerlIO_close(IoOFP(io));
3003 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3005 (void)SvREFCNT_inc(filter_sub);
3008 filter_state = SP[i];
3009 (void)SvREFCNT_inc(filter_state);
3013 tryrsfp = PerlIO_open("/dev/null",
3027 filter_has_file = 0;
3028 if (filter_child_proc) {
3029 SvREFCNT_dec(filter_child_proc);
3030 filter_child_proc = 0;
3033 SvREFCNT_dec(filter_state);
3037 SvREFCNT_dec(filter_sub);
3042 char *dir = SvPVx(dirsv, n_a);
3045 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3047 sv_setpv(namesv, unixdir);
3048 sv_catpv(namesv, unixname);
3050 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3052 TAINT_PROPER("require");
3053 tryname = SvPVX(namesv);
3054 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3056 if (tryname[0] == '.' && tryname[1] == '/')
3064 SAVECOPFILE(&PL_compiling);
3065 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3066 SvREFCNT_dec(namesv);
3068 if (PL_op->op_type == OP_REQUIRE) {
3069 char *msgstr = name;
3070 if (namesv) { /* did we lookup @INC? */
3071 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3072 SV *dirmsgsv = NEWSV(0, 0);
3073 AV *ar = GvAVn(PL_incgv);
3075 sv_catpvn(msg, " in @INC", 8);
3076 if (instr(SvPVX(msg), ".h "))
3077 sv_catpv(msg, " (change .h to .ph maybe?)");
3078 if (instr(SvPVX(msg), ".ph "))
3079 sv_catpv(msg, " (did you run h2ph?)");
3080 sv_catpv(msg, " (@INC contains:");
3081 for (i = 0; i <= AvFILL(ar); i++) {
3082 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3083 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3084 sv_catsv(msg, dirmsgsv);
3086 sv_catpvn(msg, ")", 1);
3087 SvREFCNT_dec(dirmsgsv);
3088 msgstr = SvPV_nolen(msg);
3090 DIE(aTHX_ "Can't locate %s", msgstr);
3096 SETERRNO(0, SS$_NORMAL);
3098 /* Assume success here to prevent recursive requirement. */
3099 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3100 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3104 lex_start(sv_2mortal(newSVpvn("",0)));
3105 SAVEGENERICSV(PL_rsfp_filters);
3106 PL_rsfp_filters = Nullav;
3111 SAVESPTR(PL_compiling.cop_warnings);
3112 if (PL_dowarn & G_WARN_ALL_ON)
3113 PL_compiling.cop_warnings = WARN_ALL ;
3114 else if (PL_dowarn & G_WARN_ALL_OFF)
3115 PL_compiling.cop_warnings = WARN_NONE ;
3117 PL_compiling.cop_warnings = WARN_STD ;
3119 if (filter_sub || filter_child_proc) {
3120 SV *datasv = filter_add(run_user_filter, Nullsv);
3121 IoLINES(datasv) = filter_has_file;
3122 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3123 IoTOP_GV(datasv) = (GV *)filter_state;
3124 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3127 /* switch to eval mode */
3128 push_return(PL_op->op_next);
3129 PUSHBLOCK(cx, CXt_EVAL, SP);
3130 PUSHEVAL(cx, name, Nullgv);
3132 SAVECOPLINE(&PL_compiling);
3133 CopLINE_set(&PL_compiling, 0);
3137 MUTEX_LOCK(&PL_eval_mutex);
3138 if (PL_eval_owner && PL_eval_owner != thr)
3139 while (PL_eval_owner)
3140 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3141 PL_eval_owner = thr;
3142 MUTEX_UNLOCK(&PL_eval_mutex);
3143 #endif /* USE_THREADS */
3144 return DOCATCH(doeval(G_SCALAR, NULL));
3149 return pp_require();
3155 register PERL_CONTEXT *cx;
3157 I32 gimme = GIMME_V, was = PL_sub_generation;
3158 char tmpbuf[TYPE_DIGITS(long) + 12];
3163 if (!SvPV(sv,len) || !len)
3165 TAINT_PROPER("eval");
3171 /* switch to eval mode */
3173 SAVECOPFILE(&PL_compiling);
3174 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3175 CopFILE_set(&PL_compiling, tmpbuf+2);
3176 CopLINE_set(&PL_compiling, 1);
3177 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3178 deleting the eval's FILEGV from the stash before gv_check() runs
3179 (i.e. before run-time proper). To work around the coredump that
3180 ensues, we always turn GvMULTI_on for any globals that were
3181 introduced within evals. See force_ident(). GSAR 96-10-12 */
3182 safestr = savepv(tmpbuf);
3183 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3185 PL_hints = PL_op->op_targ;
3186 SAVESPTR(PL_compiling.cop_warnings);
3187 if (!specialWARN(PL_compiling.cop_warnings)) {
3188 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3189 SAVEFREESV(PL_compiling.cop_warnings) ;
3192 push_return(PL_op->op_next);
3193 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3194 PUSHEVAL(cx, 0, Nullgv);
3196 /* prepare to compile string */
3198 if (PERLDB_LINE && PL_curstash != PL_debstash)
3199 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3202 MUTEX_LOCK(&PL_eval_mutex);
3203 if (PL_eval_owner && PL_eval_owner != thr)
3204 while (PL_eval_owner)
3205 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3206 PL_eval_owner = thr;
3207 MUTEX_UNLOCK(&PL_eval_mutex);
3208 #endif /* USE_THREADS */
3209 ret = doeval(gimme, NULL);
3210 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3211 && ret != PL_op->op_next) { /* Successive compilation. */
3212 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3214 return DOCATCH(ret);
3224 register PERL_CONTEXT *cx;
3226 U8 save_flags = PL_op -> op_flags;
3231 retop = pop_return();
3234 if (gimme == G_VOID)
3236 else if (gimme == G_SCALAR) {
3239 if (SvFLAGS(TOPs) & SVs_TEMP)
3242 *MARK = sv_mortalcopy(TOPs);
3246 *MARK = &PL_sv_undef;
3251 /* in case LEAVE wipes old return values */
3252 for (mark = newsp + 1; mark <= SP; mark++) {
3253 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3254 *mark = sv_mortalcopy(*mark);
3255 TAINT_NOT; /* Each item is independent */
3259 PL_curpm = newpm; /* Don't pop $1 et al till now */
3261 if (AvFILLp(PL_comppad_name) >= 0)
3265 assert(CvDEPTH(PL_compcv) == 1);
3267 CvDEPTH(PL_compcv) = 0;
3270 if (optype == OP_REQUIRE &&
3271 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3273 /* Unassume the success we assumed earlier. */
3274 char *name = cx->blk_eval.old_name;
3275 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3276 retop = Perl_die(aTHX_ "%s did not return a true value", name);
3277 /* die_where() did LEAVE, or we won't be here */
3281 if (!(save_flags & OPf_SPECIAL))
3291 register PERL_CONTEXT *cx;
3292 I32 gimme = GIMME_V;
3297 push_return(cLOGOP->op_other->op_next);
3298 PUSHBLOCK(cx, CXt_EVAL, SP);
3300 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3302 PL_in_eval = EVAL_INEVAL;
3305 return DOCATCH(PL_op->op_next);
3315 register PERL_CONTEXT *cx;
3323 if (gimme == G_VOID)
3325 else if (gimme == G_SCALAR) {
3328 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3331 *MARK = sv_mortalcopy(TOPs);
3335 *MARK = &PL_sv_undef;
3340 /* in case LEAVE wipes old return values */
3341 for (mark = newsp + 1; mark <= SP; mark++) {
3342 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3343 *mark = sv_mortalcopy(*mark);
3344 TAINT_NOT; /* Each item is independent */
3348 PL_curpm = newpm; /* Don't pop $1 et al till now */
3356 S_doparseform(pTHX_ SV *sv)
3359 register char *s = SvPV_force(sv, len);
3360 register char *send = s + len;
3361 register char *base;
3362 register I32 skipspaces = 0;
3365 bool postspace = FALSE;
3373 Perl_croak(aTHX_ "Null picture in formline");
3375 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3380 *fpc++ = FF_LINEMARK;
3381 noblank = repeat = FALSE;
3399 case ' ': case '\t':
3410 *fpc++ = FF_LITERAL;
3418 *fpc++ = skipspaces;
3422 *fpc++ = FF_NEWLINE;
3426 arg = fpc - linepc + 1;
3433 *fpc++ = FF_LINEMARK;
3434 noblank = repeat = FALSE;
3443 ischop = s[-1] == '^';
3449 arg = (s - base) - 1;
3451 *fpc++ = FF_LITERAL;
3460 *fpc++ = FF_LINEGLOB;
3462 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3463 arg = ischop ? 512 : 0;
3473 arg |= 256 + (s - f);
3475 *fpc++ = s - base; /* fieldsize for FETCH */
3476 *fpc++ = FF_DECIMAL;
3481 bool ismore = FALSE;
3484 while (*++s == '>') ;
3485 prespace = FF_SPACE;
3487 else if (*s == '|') {
3488 while (*++s == '|') ;
3489 prespace = FF_HALFSPACE;
3494 while (*++s == '<') ;
3497 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3501 *fpc++ = s - base; /* fieldsize for FETCH */
3503 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3521 { /* need to jump to the next word */
3523 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3524 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3525 s = SvPVX(sv) + SvCUR(sv) + z;
3527 Copy(fops, s, arg, U16);
3529 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3534 * The rest of this file was derived from source code contributed
3537 * NOTE: this code was derived from Tom Horsley's qsort replacement
3538 * and should not be confused with the original code.
3541 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3543 Permission granted to distribute under the same terms as perl which are
3546 This program is free software; you can redistribute it and/or modify
3547 it under the terms of either:
3549 a) the GNU General Public License as published by the Free
3550 Software Foundation; either version 1, or (at your option) any
3553 b) the "Artistic License" which comes with this Kit.
3555 Details on the perl license can be found in the perl source code which
3556 may be located via the www.perl.com web page.
3558 This is the most wonderfulest possible qsort I can come up with (and
3559 still be mostly portable) My (limited) tests indicate it consistently
3560 does about 20% fewer calls to compare than does the qsort in the Visual
3561 C++ library, other vendors may vary.
3563 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3564 others I invented myself (or more likely re-invented since they seemed
3565 pretty obvious once I watched the algorithm operate for a while).
3567 Most of this code was written while watching the Marlins sweep the Giants
3568 in the 1997 National League Playoffs - no Braves fans allowed to use this
3569 code (just kidding :-).
3571 I realize that if I wanted to be true to the perl tradition, the only
3572 comment in this file would be something like:
3574 ...they shuffled back towards the rear of the line. 'No, not at the
3575 rear!' the slave-driver shouted. 'Three files up. And stay there...
3577 However, I really needed to violate that tradition just so I could keep
3578 track of what happens myself, not to mention some poor fool trying to
3579 understand this years from now :-).
3582 /* ********************************************************** Configuration */
3584 #ifndef QSORT_ORDER_GUESS
3585 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3588 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3589 future processing - a good max upper bound is log base 2 of memory size
3590 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3591 safely be smaller than that since the program is taking up some space and
3592 most operating systems only let you grab some subset of contiguous
3593 memory (not to mention that you are normally sorting data larger than
3594 1 byte element size :-).
3596 #ifndef QSORT_MAX_STACK
3597 #define QSORT_MAX_STACK 32
3600 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3601 Anything bigger and we use qsort. If you make this too small, the qsort
3602 will probably break (or become less efficient), because it doesn't expect
3603 the middle element of a partition to be the same as the right or left -
3604 you have been warned).
3606 #ifndef QSORT_BREAK_EVEN
3607 #define QSORT_BREAK_EVEN 6
3610 /* ************************************************************* Data Types */
3612 /* hold left and right index values of a partition waiting to be sorted (the
3613 partition includes both left and right - right is NOT one past the end or
3614 anything like that).
3616 struct partition_stack_entry {
3619 #ifdef QSORT_ORDER_GUESS
3620 int qsort_break_even;
3624 /* ******************************************************* Shorthand Macros */
3626 /* Note that these macros will be used from inside the qsort function where
3627 we happen to know that the variable 'elt_size' contains the size of an
3628 array element and the variable 'temp' points to enough space to hold a
3629 temp element and the variable 'array' points to the array being sorted
3630 and 'compare' is the pointer to the compare routine.
3632 Also note that there are very many highly architecture specific ways
3633 these might be sped up, but this is simply the most generally portable
3634 code I could think of.
3637 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3639 #define qsort_cmp(elt1, elt2) \
3640 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3642 #ifdef QSORT_ORDER_GUESS
3643 #define QSORT_NOTICE_SWAP swapped++;
3645 #define QSORT_NOTICE_SWAP
3648 /* swaps contents of array elements elt1, elt2.
3650 #define qsort_swap(elt1, elt2) \
3653 temp = array[elt1]; \
3654 array[elt1] = array[elt2]; \
3655 array[elt2] = temp; \
3658 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3659 elt3 and elt3 gets elt1.
3661 #define qsort_rotate(elt1, elt2, elt3) \
3664 temp = array[elt1]; \
3665 array[elt1] = array[elt2]; \
3666 array[elt2] = array[elt3]; \
3667 array[elt3] = temp; \
3670 /* ************************************************************ Debug stuff */
3677 return; /* good place to set a breakpoint */
3680 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3683 doqsort_all_asserts(
3687 int (*compare)(const void * elt1, const void * elt2),
3688 int pc_left, int pc_right, int u_left, int u_right)
3692 qsort_assert(pc_left <= pc_right);
3693 qsort_assert(u_right < pc_left);
3694 qsort_assert(pc_right < u_left);
3695 for (i = u_right + 1; i < pc_left; ++i) {
3696 qsort_assert(qsort_cmp(i, pc_left) < 0);
3698 for (i = pc_left; i < pc_right; ++i) {
3699 qsort_assert(qsort_cmp(i, pc_right) == 0);
3701 for (i = pc_right + 1; i < u_left; ++i) {
3702 qsort_assert(qsort_cmp(pc_right, i) < 0);
3706 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3707 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3708 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3712 #define qsort_assert(t) ((void)0)
3714 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3718 /* ****************************************************************** qsort */
3721 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3725 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3726 int next_stack_entry = 0;
3730 #ifdef QSORT_ORDER_GUESS
3731 int qsort_break_even;
3735 /* Make sure we actually have work to do.
3737 if (num_elts <= 1) {
3741 /* Setup the initial partition definition and fall into the sorting loop
3744 part_right = (int)(num_elts - 1);
3745 #ifdef QSORT_ORDER_GUESS
3746 qsort_break_even = QSORT_BREAK_EVEN;
3748 #define qsort_break_even QSORT_BREAK_EVEN
3751 if ((part_right - part_left) >= qsort_break_even) {
3752 /* OK, this is gonna get hairy, so lets try to document all the
3753 concepts and abbreviations and variables and what they keep
3756 pc: pivot chunk - the set of array elements we accumulate in the
3757 middle of the partition, all equal in value to the original
3758 pivot element selected. The pc is defined by:
3760 pc_left - the leftmost array index of the pc
3761 pc_right - the rightmost array index of the pc
3763 we start with pc_left == pc_right and only one element
3764 in the pivot chunk (but it can grow during the scan).
3766 u: uncompared elements - the set of elements in the partition
3767 we have not yet compared to the pivot value. There are two
3768 uncompared sets during the scan - one to the left of the pc
3769 and one to the right.
3771 u_right - the rightmost index of the left side's uncompared set
3772 u_left - the leftmost index of the right side's uncompared set
3774 The leftmost index of the left sides's uncompared set
3775 doesn't need its own variable because it is always defined
3776 by the leftmost edge of the whole partition (part_left). The
3777 same goes for the rightmost edge of the right partition
3780 We know there are no uncompared elements on the left once we
3781 get u_right < part_left and no uncompared elements on the
3782 right once u_left > part_right. When both these conditions
3783 are met, we have completed the scan of the partition.
3785 Any elements which are between the pivot chunk and the
3786 uncompared elements should be less than the pivot value on
3787 the left side and greater than the pivot value on the right
3788 side (in fact, the goal of the whole algorithm is to arrange
3789 for that to be true and make the groups of less-than and
3790 greater-then elements into new partitions to sort again).
3792 As you marvel at the complexity of the code and wonder why it
3793 has to be so confusing. Consider some of the things this level
3794 of confusion brings:
3796 Once I do a compare, I squeeze every ounce of juice out of it. I
3797 never do compare calls I don't have to do, and I certainly never
3800 I also never swap any elements unless I can prove there is a
3801 good reason. Many sort algorithms will swap a known value with
3802 an uncompared value just to get things in the right place (or
3803 avoid complexity :-), but that uncompared value, once it gets
3804 compared, may then have to be swapped again. A lot of the
3805 complexity of this code is due to the fact that it never swaps
3806 anything except compared values, and it only swaps them when the
3807 compare shows they are out of position.
3809 int pc_left, pc_right;
3810 int u_right, u_left;
3814 pc_left = ((part_left + part_right) / 2);
3816 u_right = pc_left - 1;
3817 u_left = pc_right + 1;
3819 /* Qsort works best when the pivot value is also the median value
3820 in the partition (unfortunately you can't find the median value
3821 without first sorting :-), so to give the algorithm a helping
3822 hand, we pick 3 elements and sort them and use the median value
3823 of that tiny set as the pivot value.
3825 Some versions of qsort like to use the left middle and right as
3826 the 3 elements to sort so they can insure the ends of the
3827 partition will contain values which will stop the scan in the
3828 compare loop, but when you have to call an arbitrarily complex
3829 routine to do a compare, its really better to just keep track of
3830 array index values to know when you hit the edge of the
3831 partition and avoid the extra compare. An even better reason to
3832 avoid using a compare call is the fact that you can drop off the
3833 edge of the array if someone foolishly provides you with an
3834 unstable compare function that doesn't always provide consistent
3837 So, since it is simpler for us to compare the three adjacent
3838 elements in the middle of the partition, those are the ones we
3839 pick here (conveniently pointed at by u_right, pc_left, and
3840 u_left). The values of the left, center, and right elements
3841 are refered to as l c and r in the following comments.
3844 #ifdef QSORT_ORDER_GUESS
3847 s = qsort_cmp(u_right, pc_left);
3850 s = qsort_cmp(pc_left, u_left);
3851 /* if l < c, c < r - already in order - nothing to do */
3853 /* l < c, c == r - already in order, pc grows */
3855 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3857 /* l < c, c > r - need to know more */
3858 s = qsort_cmp(u_right, u_left);
3860 /* l < c, c > r, l < r - swap c & r to get ordered */
3861 qsort_swap(pc_left, u_left);
3862 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3863 } else if (s == 0) {
3864 /* l < c, c > r, l == r - swap c&r, grow pc */
3865 qsort_swap(pc_left, u_left);
3867 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3869 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3870 qsort_rotate(pc_left, u_right, u_left);
3871 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3874 } else if (s == 0) {
3876 s = qsort_cmp(pc_left, u_left);
3878 /* l == c, c < r - already in order, grow pc */
3880 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3881 } else if (s == 0) {
3882 /* l == c, c == r - already in order, grow pc both ways */
3885 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3887 /* l == c, c > r - swap l & r, grow pc */
3888 qsort_swap(u_right, u_left);
3890 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3894 s = qsort_cmp(pc_left, u_left);
3896 /* l > c, c < r - need to know more */
3897 s = qsort_cmp(u_right, u_left);
3899 /* l > c, c < r, l < r - swap l & c to get ordered */
3900 qsort_swap(u_right, pc_left);
3901 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3902 } else if (s == 0) {
3903 /* l > c, c < r, l == r - swap l & c, grow pc */
3904 qsort_swap(u_right, pc_left);
3906 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3908 /* l > c, c < r, l > r - rotate lcr into crl to order */
3909 qsort_rotate(u_right, pc_left, u_left);
3910 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3912 } else if (s == 0) {
3913 /* l > c, c == r - swap ends, grow pc */
3914 qsort_swap(u_right, u_left);
3916 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3918 /* l > c, c > r - swap ends to get in order */
3919 qsort_swap(u_right, u_left);
3920 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3923 /* We now know the 3 middle elements have been compared and
3924 arranged in the desired order, so we can shrink the uncompared
3929 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3931 /* The above massive nested if was the simple part :-). We now have
3932 the middle 3 elements ordered and we need to scan through the
3933 uncompared sets on either side, swapping elements that are on
3934 the wrong side or simply shuffling equal elements around to get
3935 all equal elements into the pivot chunk.
3939 int still_work_on_left;
3940 int still_work_on_right;
3942 /* Scan the uncompared values on the left. If I find a value
3943 equal to the pivot value, move it over so it is adjacent to
3944 the pivot chunk and expand the pivot chunk. If I find a value
3945 less than the pivot value, then just leave it - its already
3946 on the correct side of the partition. If I find a greater
3947 value, then stop the scan.
3949 while (still_work_on_left = (u_right >= part_left)) {
3950 s = qsort_cmp(u_right, pc_left);
3953 } else if (s == 0) {
3955 if (pc_left != u_right) {
3956 qsort_swap(u_right, pc_left);
3962 qsort_assert(u_right < pc_left);
3963 qsort_assert(pc_left <= pc_right);
3964 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3965 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3968 /* Do a mirror image scan of uncompared values on the right
3970 while (still_work_on_right = (u_left <= part_right)) {
3971 s = qsort_cmp(pc_right, u_left);
3974 } else if (s == 0) {
3976 if (pc_right != u_left) {
3977 qsort_swap(pc_right, u_left);
3983 qsort_assert(u_left > pc_right);
3984 qsort_assert(pc_left <= pc_right);
3985 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3986 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3989 if (still_work_on_left) {
3990 /* I know I have a value on the left side which needs to be
3991 on the right side, but I need to know more to decide
3992 exactly the best thing to do with it.
3994 if (still_work_on_right) {
3995 /* I know I have values on both side which are out of
3996 position. This is a big win because I kill two birds
3997 with one swap (so to speak). I can advance the
3998 uncompared pointers on both sides after swapping both
3999 of them into the right place.
4001 qsort_swap(u_right, u_left);
4004 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4006 /* I have an out of position value on the left, but the
4007 right is fully scanned, so I "slide" the pivot chunk
4008 and any less-than values left one to make room for the
4009 greater value over on the right. If the out of position
4010 value is immediately adjacent to the pivot chunk (there
4011 are no less-than values), I can do that with a swap,
4012 otherwise, I have to rotate one of the less than values
4013 into the former position of the out of position value
4014 and the right end of the pivot chunk into the left end
4018 if (pc_left == u_right) {
4019 qsort_swap(u_right, pc_right);
4020 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4022 qsort_rotate(u_right, pc_left, pc_right);
4023 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4028 } else if (still_work_on_right) {
4029 /* Mirror image of complex case above: I have an out of
4030 position value on the right, but the left is fully
4031 scanned, so I need to shuffle things around to make room
4032 for the right value on the left.
4035 if (pc_right == u_left) {
4036 qsort_swap(u_left, pc_left);
4037 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4039 qsort_rotate(pc_right, pc_left, u_left);
4040 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4045 /* No more scanning required on either side of partition,
4046 break out of loop and figure out next set of partitions
4052 /* The elements in the pivot chunk are now in the right place. They
4053 will never move or be compared again. All I have to do is decide
4054 what to do with the stuff to the left and right of the pivot
4057 Notes on the QSORT_ORDER_GUESS ifdef code:
4059 1. If I just built these partitions without swapping any (or
4060 very many) elements, there is a chance that the elements are
4061 already ordered properly (being properly ordered will
4062 certainly result in no swapping, but the converse can't be
4065 2. A (properly written) insertion sort will run faster on
4066 already ordered data than qsort will.
4068 3. Perhaps there is some way to make a good guess about
4069 switching to an insertion sort earlier than partition size 6
4070 (for instance - we could save the partition size on the stack
4071 and increase the size each time we find we didn't swap, thus
4072 switching to insertion sort earlier for partitions with a
4073 history of not swapping).
4075 4. Naturally, if I just switch right away, it will make
4076 artificial benchmarks with pure ascending (or descending)
4077 data look really good, but is that a good reason in general?
4081 #ifdef QSORT_ORDER_GUESS
4083 #if QSORT_ORDER_GUESS == 1
4084 qsort_break_even = (part_right - part_left) + 1;
4086 #if QSORT_ORDER_GUESS == 2
4087 qsort_break_even *= 2;
4089 #if QSORT_ORDER_GUESS == 3
4090 int prev_break = qsort_break_even;
4091 qsort_break_even *= qsort_break_even;
4092 if (qsort_break_even < prev_break) {
4093 qsort_break_even = (part_right - part_left) + 1;
4097 qsort_break_even = QSORT_BREAK_EVEN;
4101 if (part_left < pc_left) {
4102 /* There are elements on the left which need more processing.
4103 Check the right as well before deciding what to do.
4105 if (pc_right < part_right) {
4106 /* We have two partitions to be sorted. Stack the biggest one
4107 and process the smallest one on the next iteration. This
4108 minimizes the stack height by insuring that any additional
4109 stack entries must come from the smallest partition which
4110 (because it is smallest) will have the fewest
4111 opportunities to generate additional stack entries.
4113 if ((part_right - pc_right) > (pc_left - part_left)) {
4114 /* stack the right partition, process the left */
4115 partition_stack[next_stack_entry].left = pc_right + 1;
4116 partition_stack[next_stack_entry].right = part_right;
4117 #ifdef QSORT_ORDER_GUESS
4118 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4120 part_right = pc_left - 1;
4122 /* stack the left partition, process the right */
4123 partition_stack[next_stack_entry].left = part_left;
4124 partition_stack[next_stack_entry].right = pc_left - 1;
4125 #ifdef QSORT_ORDER_GUESS
4126 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4128 part_left = pc_right + 1;
4130 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4133 /* The elements on the left are the only remaining elements
4134 that need sorting, arrange for them to be processed as the
4137 part_right = pc_left - 1;
4139 } else if (pc_right < part_right) {
4140 /* There is only one chunk on the right to be sorted, make it
4141 the new partition and loop back around.
4143 part_left = pc_right + 1;
4145 /* This whole partition wound up in the pivot chunk, so
4146 we need to get a new partition off the stack.
4148 if (next_stack_entry == 0) {
4149 /* the stack is empty - we are done */
4153 part_left = partition_stack[next_stack_entry].left;
4154 part_right = partition_stack[next_stack_entry].right;
4155 #ifdef QSORT_ORDER_GUESS
4156 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4160 /* This partition is too small to fool with qsort complexity, just
4161 do an ordinary insertion sort to minimize overhead.
4164 /* Assume 1st element is in right place already, and start checking
4165 at 2nd element to see where it should be inserted.
4167 for (i = part_left + 1; i <= part_right; ++i) {
4169 /* Scan (backwards - just in case 'i' is already in right place)
4170 through the elements already sorted to see if the ith element
4171 belongs ahead of one of them.
4173 for (j = i - 1; j >= part_left; --j) {
4174 if (qsort_cmp(i, j) >= 0) {
4175 /* i belongs right after j
4182 /* Looks like we really need to move some things
4186 for (k = i - 1; k >= j; --k)
4187 array[k + 1] = array[k];
4192 /* That partition is now sorted, grab the next one, or get out
4193 of the loop if there aren't any more.
4196 if (next_stack_entry == 0) {
4197 /* the stack is empty - we are done */
4201 part_left = partition_stack[next_stack_entry].left;
4202 part_right = partition_stack[next_stack_entry].right;
4203 #ifdef QSORT_ORDER_GUESS
4204 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4209 /* Believe it or not, the array is sorted at this point! */
4221 sortcv(pTHXo_ SV *a, SV *b)
4224 I32 oldsaveix = PL_savestack_ix;
4225 I32 oldscopeix = PL_scopestack_ix;
4227 GvSV(PL_firstgv) = a;
4228 GvSV(PL_secondgv) = b;
4229 PL_stack_sp = PL_stack_base;
4232 if (PL_stack_sp != PL_stack_base + 1)
4233 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4234 if (!SvNIOKp(*PL_stack_sp))
4235 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4236 result = SvIV(*PL_stack_sp);
4237 while (PL_scopestack_ix > oldscopeix) {
4240 leave_scope(oldsaveix);
4245 sortcv_stacked(pTHXo_ SV *a, SV *b)
4248 I32 oldsaveix = PL_savestack_ix;
4249 I32 oldscopeix = PL_scopestack_ix;
4254 av = (AV*)PL_curpad[0];
4256 av = GvAV(PL_defgv);
4259 if (AvMAX(av) < 1) {
4260 SV** ary = AvALLOC(av);
4261 if (AvARRAY(av) != ary) {
4262 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4263 SvPVX(av) = (char*)ary;
4265 if (AvMAX(av) < 1) {
4268 SvPVX(av) = (char*)ary;
4275 PL_stack_sp = PL_stack_base;
4278 if (PL_stack_sp != PL_stack_base + 1)
4279 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4280 if (!SvNIOKp(*PL_stack_sp))
4281 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4282 result = SvIV(*PL_stack_sp);
4283 while (PL_scopestack_ix > oldscopeix) {
4286 leave_scope(oldsaveix);
4291 sortcv_xsub(pTHXo_ SV *a, SV *b)
4294 I32 oldsaveix = PL_savestack_ix;
4295 I32 oldscopeix = PL_scopestack_ix;
4297 CV *cv=(CV*)PL_sortcop;
4305 (void)(*CvXSUB(cv))(aTHXo_ cv);
4306 if (PL_stack_sp != PL_stack_base + 1)
4307 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4308 if (!SvNIOKp(*PL_stack_sp))
4309 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4310 result = SvIV(*PL_stack_sp);
4311 while (PL_scopestack_ix > oldscopeix) {
4314 leave_scope(oldsaveix);
4320 sv_ncmp(pTHXo_ SV *a, SV *b)
4324 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4328 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4332 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4334 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4336 if (PL_amagic_generation) { \
4337 if (SvAMAGIC(left)||SvAMAGIC(right))\
4338 *svp = amagic_call(left, \
4346 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4349 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4354 I32 i = SvIVX(tmpsv);
4364 return sv_ncmp(aTHXo_ a, b);
4368 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4371 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4376 I32 i = SvIVX(tmpsv);
4386 return sv_i_ncmp(aTHXo_ a, b);
4390 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4393 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4398 I32 i = SvIVX(tmpsv);
4408 return sv_cmp(str1, str2);
4412 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4415 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4420 I32 i = SvIVX(tmpsv);
4430 return sv_cmp_locale(str1, str2);
4434 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4436 SV *datasv = FILTER_DATA(idx);
4437 int filter_has_file = IoLINES(datasv);
4438 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4439 SV *filter_state = (SV *)IoTOP_GV(datasv);
4440 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4443 /* I was having segfault trouble under Linux 2.2.5 after a
4444 parse error occured. (Had to hack around it with a test
4445 for PL_error_count == 0.) Solaris doesn't segfault --
4446 not sure where the trouble is yet. XXX */
4448 if (filter_has_file) {
4449 len = FILTER_READ(idx+1, buf_sv, maxlen);
4452 if (filter_sub && len >= 0) {
4463 PUSHs(sv_2mortal(newSViv(maxlen)));
4465 PUSHs(filter_state);
4468 count = call_sv(filter_sub, G_SCALAR);
4484 IoLINES(datasv) = 0;
4485 if (filter_child_proc) {
4486 SvREFCNT_dec(filter_child_proc);
4487 IoFMT_GV(datasv) = Nullgv;
4490 SvREFCNT_dec(filter_state);
4491 IoTOP_GV(datasv) = Nullgv;
4494 SvREFCNT_dec(filter_sub);
4495 IoBOTTOM_GV(datasv) = Nullgv;
4497 filter_del(run_user_filter);
4506 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4508 return sv_cmp_locale(str1, str2);
4512 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4514 return sv_cmp(str1, str2);
4517 #endif /* PERL_OBJECT */