3 * Copyright (c) 1991-1997, 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.
23 #define WORD_ALIGN sizeof(U16)
26 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 #define CALLOP this->*PL_op
32 static OP *docatch _((OP *o));
33 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
34 static void doparseform _((SV *sv));
35 static I32 dopoptoeval _((I32 startingblock));
36 static I32 dopoptolabel _((char *label));
37 static I32 dopoptoloop _((I32 startingblock));
38 static I32 dopoptosub _((I32 startingblock));
39 static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
40 static void save_lines _((AV *array, SV *sv));
41 static I32 sortcv _((SV *a, SV *b));
42 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
43 static OP *doeval _((int gimme, OP** startop));
44 static I32 sv_ncmp _((SV *a, SV *b));
45 static I32 sv_i_ncmp _((SV *a, SV *b));
46 static I32 amagic_ncmp _((SV *a, SV *b));
47 static I32 amagic_i_ncmp _((SV *a, SV *b));
48 I32 amagic_cmp _((SV *str1, SV *str2));
49 I32 amagic_cmp_locale _((SV *str1, SV *str2));
58 cxix = dopoptosub(cxstack_ix);
62 switch (cxstack[cxix].blk_gimme) {
79 /* XXXX Should store the old value to allow for tie/overload - and
80 restore in regcomp, where marked with XXXX. */
88 register PMOP *pm = (PMOP*)cLOGOP->op_other;
92 MAGIC *mg = Null(MAGIC*);
96 SV *sv = SvRV(tmpstr);
98 mg = mg_find(sv, 'r');
101 regexp *re = (regexp *)mg->mg_obj;
102 ReREFCNT_dec(pm->op_pmregexp);
103 pm->op_pmregexp = ReREFCNT_inc(re);
106 t = SvPV(tmpstr, len);
108 /* Check against the last compiled regexp. */
109 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
110 pm->op_pmregexp->prelen != len ||
111 memNE(pm->op_pmregexp->precomp, t, len))
113 if (pm->op_pmregexp) {
114 ReREFCNT_dec(pm->op_pmregexp);
115 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
117 if (PL_op->op_flags & OPf_SPECIAL)
118 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
120 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
121 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
122 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
123 inside tie/overload accessors. */
127 #ifndef INCOMPLETE_TAINTS
130 pm->op_pmdynflags |= PMdf_TAINTED;
132 pm->op_pmdynflags &= ~PMdf_TAINTED;
136 if (!pm->op_pmregexp->prelen && PL_curpm)
138 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
139 pm->op_pmflags |= PMf_WHITE;
141 if (pm->op_pmflags & PMf_KEEP) {
142 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
143 cLOGOP->op_first->op_next = PL_op->op_next;
151 register PMOP *pm = (PMOP*) cLOGOP->op_other;
152 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
153 register SV *dstr = cx->sb_dstr;
154 register char *s = cx->sb_s;
155 register char *m = cx->sb_m;
156 char *orig = cx->sb_orig;
157 register REGEXP *rx = cx->sb_rx;
159 rxres_restore(&cx->sb_rxres, rx);
161 if (cx->sb_iters++) {
162 if (cx->sb_iters > cx->sb_maxiters)
163 DIE("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(rx, s, cx->sb_strend, orig,
171 s == m, cx->sb_targ, NULL,
172 ((cx->sb_rflags & REXEC_COPY_STR)
174 : (REXEC_COPY_STR|REXEC_IGNOREPOS))))
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->subbase && rx->subbase != orig) {
205 cx->sb_orig = orig = rx->subbase;
207 cx->sb_strend = s + (cx->sb_strend - m);
209 cx->sb_m = m = rx->startp[0];
210 sv_catpvn(dstr, s, m-s);
211 cx->sb_s = rx->endp[0];
212 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
213 rxres_save(&cx->sb_rxres, rx);
214 RETURNOP(pm->op_pmreplstart);
218 rxres_save(void **rsp, REGEXP *rx)
223 if (!p || p[1] < rx->nparens) {
224 i = 6 + rx->nparens * 2;
232 *p++ = (UV)rx->subbase;
233 rx->subbase = Nullch;
237 *p++ = (UV)rx->subbeg;
238 *p++ = (UV)rx->subend;
239 for (i = 0; i <= rx->nparens; ++i) {
240 *p++ = (UV)rx->startp[i];
241 *p++ = (UV)rx->endp[i];
246 rxres_restore(void **rsp, REGEXP *rx)
251 Safefree(rx->subbase);
252 rx->subbase = (char*)(*p);
257 rx->subbeg = (char*)(*p++);
258 rx->subend = (char*)(*p++);
259 for (i = 0; i <= rx->nparens; ++i) {
260 rx->startp[i] = (char*)(*p++);
261 rx->endp[i] = (char*)(*p++);
266 rxres_free(void **rsp)
271 Safefree((char*)(*p));
279 djSP; dMARK; dORIGMARK;
280 register SV *tmpForm = *++MARK;
292 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
298 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
300 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
301 SvREADONLY_off(tmpForm);
302 doparseform(tmpForm);
305 SvPV_force(PL_formtarget, len);
306 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
308 f = SvPV(tmpForm, len);
309 /* need to jump to the next word */
310 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
319 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
320 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
321 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
322 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
323 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
325 case FF_CHECKNL: name = "CHECKNL"; break;
326 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
327 case FF_SPACE: name = "SPACE"; break;
328 case FF_HALFSPACE: name = "HALFSPACE"; break;
329 case FF_ITEM: name = "ITEM"; break;
330 case FF_CHOP: name = "CHOP"; break;
331 case FF_LINEGLOB: name = "LINEGLOB"; break;
332 case FF_NEWLINE: name = "NEWLINE"; break;
333 case FF_MORE: name = "MORE"; break;
334 case FF_LINEMARK: name = "LINEMARK"; break;
335 case FF_END: name = "END"; break;
338 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
340 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
368 if (ckWARN(WARN_SYNTAX))
369 warner(WARN_SYNTAX, "Not enough format arguments");
374 item = s = SvPV(sv, len);
377 itemsize = sv_len_utf8(sv);
378 if (itemsize != len) {
380 if (itemsize > fieldsize) {
381 itemsize = fieldsize;
382 itembytes = itemsize;
383 sv_pos_u2b(sv, &itembytes, 0);
387 send = chophere = s + itembytes;
396 sv_pos_b2u(sv, &itemsize);
400 if (itemsize > fieldsize)
401 itemsize = fieldsize;
402 send = chophere = s + itemsize;
414 item = s = SvPV(sv, len);
417 itemsize = sv_len_utf8(sv);
418 if (itemsize != len) {
420 if (itemsize <= fieldsize) {
421 send = chophere = s + itemsize;
432 itemsize = fieldsize;
433 itembytes = itemsize;
434 sv_pos_u2b(sv, &itembytes, 0);
435 send = chophere = s + itembytes;
436 while (s < send || (s == send && isSPACE(*s))) {
446 if (strchr(PL_chopset, *s))
451 itemsize = chophere - item;
452 sv_pos_b2u(sv, &itemsize);
457 if (itemsize <= fieldsize) {
458 send = chophere = s + itemsize;
469 itemsize = fieldsize;
470 send = chophere = s + itemsize;
471 while (s < send || (s == send && isSPACE(*s))) {
481 if (strchr(PL_chopset, *s))
486 itemsize = chophere - item;
491 arg = fieldsize - itemsize;
500 arg = fieldsize - itemsize;
515 switch (UTF8SKIP(s)) {
526 if ( !((*t++ = *s++) & ~31) )
534 int ch = *t++ = *s++;
537 if ( !((*t++ = *s++) & ~31) )
546 while (*s && isSPACE(*s))
553 item = s = SvPV(sv, len);
566 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
567 sv_catpvn(PL_formtarget, item, itemsize);
568 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
569 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
574 /* If the field is marked with ^ and the value is undefined,
577 if ((arg & 512) && !SvOK(sv)) {
585 /* Formats aren't yet marked for locales, so assume "yes". */
588 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
590 sprintf(t, "%*.0f", (int) fieldsize, value);
597 while (t-- > linemark && *t == ' ') ;
605 if (arg) { /* repeat until fields exhausted? */
607 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
608 lines += FmLINES(PL_formtarget);
611 if (strnEQ(linemark, linemark - arg, arg))
612 DIE("Runaway format");
614 FmLINES(PL_formtarget) = lines;
616 RETURNOP(cLISTOP->op_first);
629 while (*s && isSPACE(*s) && s < send)
633 arg = fieldsize - itemsize;
640 if (strnEQ(s," ",3)) {
641 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
652 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
653 FmLINES(PL_formtarget) += lines;
665 if (PL_stack_base + *PL_markstack_ptr == SP) {
667 if (GIMME_V == G_SCALAR)
669 RETURNOP(PL_op->op_next->op_next);
671 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
672 pp_pushmark(ARGS); /* push dst */
673 pp_pushmark(ARGS); /* push src */
674 ENTER; /* enter outer scope */
677 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
679 ENTER; /* enter inner scope */
682 src = PL_stack_base[*PL_markstack_ptr];
687 if (PL_op->op_type == OP_MAPSTART)
688 pp_pushmark(ARGS); /* push top */
689 return ((LOGOP*)PL_op->op_next)->op_other;
694 DIE("panic: mapstart"); /* uses grepstart */
700 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
706 ++PL_markstack_ptr[-1];
708 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
709 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
710 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
715 PL_markstack_ptr[-1] += shift;
716 *PL_markstack_ptr += shift;
720 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
723 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
725 LEAVE; /* exit inner scope */
728 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
732 (void)POPMARK; /* pop top */
733 LEAVE; /* exit outer scope */
734 (void)POPMARK; /* pop src */
735 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
736 (void)POPMARK; /* pop dst */
737 SP = PL_stack_base + POPMARK; /* pop original mark */
738 if (gimme == G_SCALAR) {
742 else if (gimme == G_ARRAY)
749 ENTER; /* enter inner scope */
752 src = PL_stack_base[PL_markstack_ptr[-1]];
756 RETURNOP(cLOGOP->op_other);
761 sv_ncmp (SV *a, SV *b)
763 double nv1 = SvNV(a);
764 double nv2 = SvNV(b);
765 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
768 sv_i_ncmp (SV *a, SV *b)
772 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
774 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
776 if (PL_amagic_generation) { \
777 if (SvAMAGIC(left)||SvAMAGIC(right))\
778 *svp = amagic_call(left, \
786 amagic_ncmp(register SV *a, register SV *b)
789 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
794 I32 i = SvIVX(tmpsv);
804 return sv_ncmp(a, b);
808 amagic_i_ncmp(register SV *a, register SV *b)
811 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
816 I32 i = SvIVX(tmpsv);
826 return sv_i_ncmp(a, b);
830 amagic_cmp(register SV *str1, register SV *str2)
833 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
838 I32 i = SvIVX(tmpsv);
848 return sv_cmp(str1, str2);
852 amagic_cmp_locale(register SV *str1, register SV *str2)
855 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
860 I32 i = SvIVX(tmpsv);
870 return sv_cmp_locale(str1, str2);
875 djSP; dMARK; dORIGMARK;
877 SV **myorigmark = ORIGMARK;
883 OP* nextop = PL_op->op_next;
886 if (gimme != G_ARRAY) {
892 SAVEPPTR(PL_sortcop);
893 if (PL_op->op_flags & OPf_STACKED) {
894 if (PL_op->op_flags & OPf_SPECIAL) {
895 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
896 kid = kUNOP->op_first; /* pass rv2gv */
897 kid = kUNOP->op_first; /* pass leave */
898 PL_sortcop = kid->op_next;
899 stash = PL_curcop->cop_stash;
902 cv = sv_2cv(*++MARK, &stash, &gv, 0);
903 if (!(cv && CvROOT(cv))) {
905 SV *tmpstr = sv_newmortal();
906 gv_efullname3(tmpstr, gv, Nullch);
907 if (cv && CvXSUB(cv))
908 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
909 DIE("Undefined sort subroutine \"%s\" called",
914 DIE("Xsub called in sort");
915 DIE("Undefined subroutine in sort");
917 DIE("Not a CODE reference in sort");
919 PL_sortcop = CvSTART(cv);
920 SAVESPTR(CvROOT(cv)->op_ppaddr);
921 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
924 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
929 stash = PL_curcop->cop_stash;
933 while (MARK < SP) { /* This may or may not shift down one here. */
935 if (*up = *++MARK) { /* Weed out nulls. */
937 if (!PL_sortcop && !SvPOK(*up)) {
942 (void)sv_2pv(*up, &n_a);
947 max = --up - myorigmark;
952 bool oldcatch = CATCH_GET;
958 PUSHSTACKi(PERLSI_SORT);
959 if (PL_sortstash != stash) {
960 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
961 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
962 PL_sortstash = stash;
965 SAVESPTR(GvSV(PL_firstgv));
966 SAVESPTR(GvSV(PL_secondgv));
968 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
969 if (!(PL_op->op_flags & OPf_SPECIAL)) {
970 bool hasargs = FALSE;
971 cx->cx_type = CXt_SUB;
972 cx->blk_gimme = G_SCALAR;
975 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
977 PL_sortcxix = cxstack_ix;
978 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
980 POPBLOCK(cx,PL_curpm);
988 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
989 qsortsv(ORIGMARK+1, max,
990 (PL_op->op_private & OPpSORT_NUMERIC)
991 ? ( (PL_op->op_private & OPpSORT_INTEGER)
993 ? FUNC_NAME_TO_PTR(amagic_i_ncmp)
994 : FUNC_NAME_TO_PTR(sv_i_ncmp))
996 ? FUNC_NAME_TO_PTR(amagic_ncmp)
997 : FUNC_NAME_TO_PTR(sv_ncmp)))
998 : ( (PL_op->op_private & OPpLOCALE)
1000 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
1001 : FUNC_NAME_TO_PTR(sv_cmp_locale))
1003 ? FUNC_NAME_TO_PTR(amagic_cmp)
1004 : FUNC_NAME_TO_PTR(sv_cmp) )));
1005 if (PL_op->op_private & OPpSORT_REVERSE) {
1006 SV **p = ORIGMARK+1;
1007 SV **q = ORIGMARK+max;
1017 PL_stack_sp = ORIGMARK + max;
1025 if (GIMME == G_ARRAY)
1026 return cCONDOP->op_true;
1027 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
1034 if (GIMME == G_ARRAY) {
1035 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1039 SV *targ = PAD_SV(PL_op->op_targ);
1041 if ((PL_op->op_private & OPpFLIP_LINENUM)
1042 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1044 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1045 if (PL_op->op_flags & OPf_SPECIAL) {
1053 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1066 if (GIMME == G_ARRAY) {
1072 if (SvNIOKp(left) || !SvPOKp(left) ||
1073 (looks_like_number(left) && *SvPVX(left) != '0') )
1075 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
1076 croak("Range iterator outside integer range");
1080 EXTEND_MORTAL(max - i + 1);
1081 EXTEND(SP, max - i + 1);
1084 sv = sv_2mortal(newSViv(i++));
1089 SV *final = sv_mortalcopy(right);
1091 char *tmps = SvPV(final, len);
1093 sv = sv_mortalcopy(left);
1095 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1097 if (strEQ(SvPVX(sv),tmps))
1099 sv = sv_2mortal(newSVsv(sv));
1106 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1108 if ((PL_op->op_private & OPpFLIP_LINENUM)
1109 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1111 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1112 sv_catpv(targ, "E0");
1123 dopoptolabel(char *label)
1127 register PERL_CONTEXT *cx;
1129 for (i = cxstack_ix; i >= 0; i--) {
1131 switch (CxTYPE(cx)) {
1133 if (ckWARN(WARN_UNSAFE))
1134 warner(WARN_UNSAFE, "Exiting substitution via %s",
1135 PL_op_name[PL_op->op_type]);
1138 if (ckWARN(WARN_UNSAFE))
1139 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1140 PL_op_name[PL_op->op_type]);
1143 if (ckWARN(WARN_UNSAFE))
1144 warner(WARN_UNSAFE, "Exiting eval via %s",
1145 PL_op_name[PL_op->op_type]);
1148 if (ckWARN(WARN_UNSAFE))
1149 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1150 PL_op_name[PL_op->op_type]);
1153 if (!cx->blk_loop.label ||
1154 strNE(label, cx->blk_loop.label) ) {
1155 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1156 (long)i, cx->blk_loop.label));
1159 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1169 I32 gimme = block_gimme();
1170 return (gimme == G_VOID) ? G_SCALAR : gimme;
1179 cxix = dopoptosub(cxstack_ix);
1183 switch (cxstack[cxix].blk_gimme) {
1191 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1198 dopoptosub(I32 startingblock)
1201 return dopoptosub_at(cxstack, startingblock);
1205 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1209 register PERL_CONTEXT *cx;
1210 for (i = startingblock; i >= 0; i--) {
1212 switch (CxTYPE(cx)) {
1217 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1225 dopoptoeval(I32 startingblock)
1229 register PERL_CONTEXT *cx;
1230 for (i = startingblock; i >= 0; i--) {
1232 switch (CxTYPE(cx)) {
1236 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1244 dopoptoloop(I32 startingblock)
1248 register PERL_CONTEXT *cx;
1249 for (i = startingblock; i >= 0; i--) {
1251 switch (CxTYPE(cx)) {
1253 if (ckWARN(WARN_UNSAFE))
1254 warner(WARN_UNSAFE, "Exiting substitution via %s",
1255 PL_op_name[PL_op->op_type]);
1258 if (ckWARN(WARN_UNSAFE))
1259 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1260 PL_op_name[PL_op->op_type]);
1263 if (ckWARN(WARN_UNSAFE))
1264 warner(WARN_UNSAFE, "Exiting eval via %s",
1265 PL_op_name[PL_op->op_type]);
1268 if (ckWARN(WARN_UNSAFE))
1269 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1270 PL_op_name[PL_op->op_type]);
1273 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1284 register PERL_CONTEXT *cx;
1288 while (cxstack_ix > cxix) {
1289 cx = &cxstack[cxstack_ix];
1290 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1291 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1292 /* Note: we don't need to restore the base context info till the end. */
1293 switch (CxTYPE(cx)) {
1296 continue; /* not break */
1314 die_where(char *message)
1320 register PERL_CONTEXT *cx;
1325 if (PL_in_eval & 4) {
1327 STRLEN klen = strlen(message);
1329 svp = hv_fetch(ERRHV, message, klen, TRUE);
1332 static char prefix[] = "\t(in cleanup) ";
1334 sv_upgrade(*svp, SVt_IV);
1335 (void)SvIOK_only(*svp);
1338 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1339 sv_catpvn(err, prefix, sizeof(prefix)-1);
1340 sv_catpvn(err, message, klen);
1341 if (ckWARN(WARN_UNSAFE)) {
1342 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1343 warner(WARN_UNSAFE, SvPVX(err)+start);
1350 sv_setpv(ERRSV, message);
1353 message = SvPVx(ERRSV, n_a);
1355 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1363 if (cxix < cxstack_ix)
1366 POPBLOCK(cx,PL_curpm);
1367 if (CxTYPE(cx) != CXt_EVAL) {
1368 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1373 if (gimme == G_SCALAR)
1374 *++newsp = &PL_sv_undef;
1375 PL_stack_sp = newsp;
1379 if (optype == OP_REQUIRE) {
1380 char* msg = SvPVx(ERRSV, n_a);
1381 DIE("%s", *msg ? msg : "Compilation failed in require");
1383 return pop_return();
1387 message = SvPVx(ERRSV, n_a);
1388 PerlIO_printf(PerlIO_stderr(), "%s",message);
1389 PerlIO_flush(PerlIO_stderr());
1398 if (SvTRUE(left) != SvTRUE(right))
1410 RETURNOP(cLOGOP->op_other);
1419 RETURNOP(cLOGOP->op_other);
1425 register I32 cxix = dopoptosub(cxstack_ix);
1426 register PERL_CONTEXT *cx;
1427 register PERL_CONTEXT *ccstack = cxstack;
1428 PERL_SI *top_si = PL_curstackinfo;
1439 /* we may be in a higher stacklevel, so dig down deeper */
1440 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1441 top_si = top_si->si_prev;
1442 ccstack = top_si->si_cxstack;
1443 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1446 if (GIMME != G_ARRAY)
1450 if (PL_DBsub && cxix >= 0 &&
1451 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1455 cxix = dopoptosub_at(ccstack, cxix - 1);
1458 cx = &ccstack[cxix];
1459 if (CxTYPE(cx) == CXt_SUB) {
1460 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1461 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1462 field below is defined for any cx. */
1463 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1464 cx = &ccstack[dbcxix];
1467 if (GIMME != G_ARRAY) {
1468 hv = cx->blk_oldcop->cop_stash;
1470 PUSHs(&PL_sv_undef);
1473 sv_setpv(TARG, HvNAME(hv));
1479 hv = cx->blk_oldcop->cop_stash;
1481 PUSHs(&PL_sv_undef);
1483 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1484 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1485 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1488 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1490 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1491 PUSHs(sv_2mortal(sv));
1492 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1495 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1496 PUSHs(sv_2mortal(newSViv(0)));
1498 gimme = (I32)cx->blk_gimme;
1499 if (gimme == G_VOID)
1500 PUSHs(&PL_sv_undef);
1502 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1503 if (CxTYPE(cx) == CXt_EVAL) {
1504 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1505 PUSHs(cx->blk_eval.cur_text);
1508 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1509 /* Require, put the name. */
1510 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1514 else if (CxTYPE(cx) == CXt_SUB &&
1515 cx->blk_sub.hasargs &&
1516 PL_curcop->cop_stash == PL_debstash)
1518 AV *ary = cx->blk_sub.argarray;
1519 int off = AvARRAY(ary) - AvALLOC(ary);
1523 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1526 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1529 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1530 av_extend(PL_dbargs, AvFILLp(ary) + off);
1531 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1532 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1538 sortcv(SV *a, SV *b)
1541 I32 oldsaveix = PL_savestack_ix;
1542 I32 oldscopeix = PL_scopestack_ix;
1544 GvSV(PL_firstgv) = a;
1545 GvSV(PL_secondgv) = b;
1546 PL_stack_sp = PL_stack_base;
1549 if (PL_stack_sp != PL_stack_base + 1)
1550 croak("Sort subroutine didn't return single value");
1551 if (!SvNIOKp(*PL_stack_sp))
1552 croak("Sort subroutine didn't return a numeric value");
1553 result = SvIV(*PL_stack_sp);
1554 while (PL_scopestack_ix > oldscopeix) {
1557 leave_scope(oldsaveix);
1571 sv_reset(tmps, PL_curcop->cop_stash);
1583 PL_curcop = (COP*)PL_op;
1584 TAINT_NOT; /* Each statement is presumed innocent */
1585 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1588 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1592 register PERL_CONTEXT *cx;
1593 I32 gimme = G_ARRAY;
1600 DIE("No DB::DB routine defined");
1602 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1614 push_return(PL_op->op_next);
1615 PUSHBLOCK(cx, CXt_SUB, SP);
1618 (void)SvREFCNT_inc(cv);
1619 SAVESPTR(PL_curpad);
1620 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1621 RETURNOP(CvSTART(cv));
1635 register PERL_CONTEXT *cx;
1636 I32 gimme = GIMME_V;
1643 if (PL_op->op_flags & OPf_SPECIAL)
1644 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
1646 #endif /* USE_THREADS */
1647 if (PL_op->op_targ) {
1648 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1653 (void)save_scalar(gv);
1654 svp = &GvSV(gv); /* symbol table variable */
1659 PUSHBLOCK(cx, CXt_LOOP, SP);
1660 PUSHLOOP(cx, svp, MARK);
1661 if (PL_op->op_flags & OPf_STACKED) {
1662 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1663 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1665 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1666 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1667 if (SvNV(sv) < IV_MIN ||
1668 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1669 croak("Range iterator outside integer range");
1670 cx->blk_loop.iterix = SvIV(sv);
1671 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1674 cx->blk_loop.iterlval = newSVsv(sv);
1678 cx->blk_loop.iterary = PL_curstack;
1679 AvFILLp(PL_curstack) = SP - PL_stack_base;
1680 cx->blk_loop.iterix = MARK - PL_stack_base;
1689 register PERL_CONTEXT *cx;
1690 I32 gimme = GIMME_V;
1696 PUSHBLOCK(cx, CXt_LOOP, SP);
1697 PUSHLOOP(cx, 0, SP);
1705 register PERL_CONTEXT *cx;
1706 struct block_loop cxloop;
1714 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1717 if (gimme == G_VOID)
1719 else if (gimme == G_SCALAR) {
1721 *++newsp = sv_mortalcopy(*SP);
1723 *++newsp = &PL_sv_undef;
1727 *++newsp = sv_mortalcopy(*++mark);
1728 TAINT_NOT; /* Each item is independent */
1734 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1735 PL_curpm = newpm; /* ... and pop $1 et al */
1747 register PERL_CONTEXT *cx;
1748 struct block_sub cxsub;
1749 bool popsub2 = FALSE;
1755 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1756 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1757 if (cxstack_ix > PL_sortcxix)
1758 dounwind(PL_sortcxix);
1759 AvARRAY(PL_curstack)[1] = *SP;
1760 PL_stack_sp = PL_stack_base + 1;
1765 cxix = dopoptosub(cxstack_ix);
1767 DIE("Can't return outside a subroutine");
1768 if (cxix < cxstack_ix)
1772 switch (CxTYPE(cx)) {
1774 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1779 if (optype == OP_REQUIRE &&
1780 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1782 /* Unassume the success we assumed earlier. */
1783 char *name = cx->blk_eval.old_name;
1784 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1785 DIE("%s did not return a true value", name);
1789 DIE("panic: return");
1793 if (gimme == G_SCALAR) {
1796 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1798 *++newsp = SvREFCNT_inc(*SP);
1803 *++newsp = sv_mortalcopy(*SP);
1806 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1808 *++newsp = sv_mortalcopy(*SP);
1810 *++newsp = &PL_sv_undef;
1812 else if (gimme == G_ARRAY) {
1813 while (++MARK <= SP) {
1814 *++newsp = (popsub2 && SvTEMP(*MARK))
1815 ? *MARK : sv_mortalcopy(*MARK);
1816 TAINT_NOT; /* Each item is independent */
1819 PL_stack_sp = newsp;
1821 /* Stack values are safe: */
1823 POPSUB2(); /* release CV and @_ ... */
1825 PL_curpm = newpm; /* ... and pop $1 et al */
1828 return pop_return();
1835 register PERL_CONTEXT *cx;
1836 struct block_loop cxloop;
1837 struct block_sub cxsub;
1844 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1846 if (PL_op->op_flags & OPf_SPECIAL) {
1847 cxix = dopoptoloop(cxstack_ix);
1849 DIE("Can't \"last\" outside a block");
1852 cxix = dopoptolabel(cPVOP->op_pv);
1854 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1856 if (cxix < cxstack_ix)
1860 switch (CxTYPE(cx)) {
1862 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1864 nextop = cxloop.last_op->op_next;
1867 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1869 nextop = pop_return();
1873 nextop = pop_return();
1880 if (gimme == G_SCALAR) {
1882 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1883 ? *SP : sv_mortalcopy(*SP);
1885 *++newsp = &PL_sv_undef;
1887 else if (gimme == G_ARRAY) {
1888 while (++MARK <= SP) {
1889 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1890 ? *MARK : sv_mortalcopy(*MARK);
1891 TAINT_NOT; /* Each item is independent */
1897 /* Stack values are safe: */
1900 POPLOOP2(); /* release loop vars ... */
1904 POPSUB2(); /* release CV and @_ ... */
1907 PL_curpm = newpm; /* ... and pop $1 et al */
1916 register PERL_CONTEXT *cx;
1919 if (PL_op->op_flags & OPf_SPECIAL) {
1920 cxix = dopoptoloop(cxstack_ix);
1922 DIE("Can't \"next\" outside a block");
1925 cxix = dopoptolabel(cPVOP->op_pv);
1927 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1929 if (cxix < cxstack_ix)
1933 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1934 LEAVE_SCOPE(oldsave);
1935 return cx->blk_loop.next_op;
1941 register PERL_CONTEXT *cx;
1944 if (PL_op->op_flags & OPf_SPECIAL) {
1945 cxix = dopoptoloop(cxstack_ix);
1947 DIE("Can't \"redo\" outside a block");
1950 cxix = dopoptolabel(cPVOP->op_pv);
1952 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1954 if (cxix < cxstack_ix)
1958 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1959 LEAVE_SCOPE(oldsave);
1960 return cx->blk_loop.redo_op;
1964 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1968 static char too_deep[] = "Target of goto is too deeply nested";
1972 if (o->op_type == OP_LEAVE ||
1973 o->op_type == OP_SCOPE ||
1974 o->op_type == OP_LEAVELOOP ||
1975 o->op_type == OP_LEAVETRY)
1977 *ops++ = cUNOPo->op_first;
1982 if (o->op_flags & OPf_KIDS) {
1984 /* First try all the kids at this level, since that's likeliest. */
1985 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1986 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1987 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1990 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1991 if (kid == PL_lastgotoprobe)
1993 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1995 (ops[-1]->op_type != OP_NEXTSTATE &&
1996 ops[-1]->op_type != OP_DBSTATE)))
1998 if (o = dofindlabel(kid, label, ops, oplimit))
2008 return pp_goto(ARGS);
2017 register PERL_CONTEXT *cx;
2018 #define GOTO_DEPTH 64
2019 OP *enterops[GOTO_DEPTH];
2021 int do_dump = (PL_op->op_type == OP_DUMP);
2024 if (PL_op->op_flags & OPf_STACKED) {
2028 /* This egregious kludge implements goto &subroutine */
2029 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2031 register PERL_CONTEXT *cx;
2032 CV* cv = (CV*)SvRV(sv);
2036 int arg_was_real = 0;
2039 if (!CvROOT(cv) && !CvXSUB(cv)) {
2044 /* autoloaded stub? */
2045 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2047 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2048 GvNAMELEN(gv), FALSE);
2049 if (autogv && (cv = GvCV(autogv)))
2051 tmpstr = sv_newmortal();
2052 gv_efullname3(tmpstr, gv, Nullch);
2053 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2055 DIE("Goto undefined subroutine");
2058 /* First do some returnish stuff. */
2059 cxix = dopoptosub(cxstack_ix);
2061 DIE("Can't goto subroutine outside a subroutine");
2062 if (cxix < cxstack_ix)
2065 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2066 DIE("Can't goto subroutine from an eval-string");
2068 if (CxTYPE(cx) == CXt_SUB &&
2069 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2070 AV* av = cx->blk_sub.argarray;
2072 items = AvFILLp(av) + 1;
2074 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2075 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2076 PL_stack_sp += items;
2078 SvREFCNT_dec(GvAV(PL_defgv));
2079 GvAV(PL_defgv) = cx->blk_sub.savearray;
2080 #endif /* USE_THREADS */
2083 AvREAL_off(av); /* so av_clear() won't clobber elts */
2087 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2091 av = (AV*)PL_curpad[0];
2093 av = GvAV(PL_defgv);
2095 items = AvFILLp(av) + 1;
2097 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2098 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2099 PL_stack_sp += items;
2101 if (CxTYPE(cx) == CXt_SUB &&
2102 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2103 SvREFCNT_dec(cx->blk_sub.cv);
2104 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2105 LEAVE_SCOPE(oldsave);
2107 /* Now do some callish stuff. */
2110 if (CvOLDSTYLE(cv)) {
2111 I32 (*fp3)_((int,int,int));
2116 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2117 items = (*fp3)(CvXSUBANY(cv).any_i32,
2118 mark - PL_stack_base + 1,
2120 SP = PL_stack_base + items;
2126 PL_stack_sp--; /* There is no cv arg. */
2127 /* Push a mark for the start of arglist */
2129 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2130 /* Pop the current context like a decent sub should */
2131 POPBLOCK(cx, PL_curpm);
2132 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2135 return pop_return();
2138 AV* padlist = CvPADLIST(cv);
2139 SV** svp = AvARRAY(padlist);
2140 if (CxTYPE(cx) == CXt_EVAL) {
2141 PL_in_eval = cx->blk_eval.old_in_eval;
2142 PL_eval_root = cx->blk_eval.old_eval_root;
2143 cx->cx_type = CXt_SUB;
2144 cx->blk_sub.hasargs = 0;
2146 cx->blk_sub.cv = cv;
2147 cx->blk_sub.olddepth = CvDEPTH(cv);
2149 if (CvDEPTH(cv) < 2)
2150 (void)SvREFCNT_inc(cv);
2151 else { /* save temporaries on recursion? */
2152 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2153 sub_crush_depth(cv);
2154 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2155 AV *newpad = newAV();
2156 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2157 I32 ix = AvFILLp((AV*)svp[1]);
2158 svp = AvARRAY(svp[0]);
2159 for ( ;ix > 0; ix--) {
2160 if (svp[ix] != &PL_sv_undef) {
2161 char *name = SvPVX(svp[ix]);
2162 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2165 /* outer lexical or anon code */
2166 av_store(newpad, ix,
2167 SvREFCNT_inc(oldpad[ix]) );
2169 else { /* our own lexical */
2171 av_store(newpad, ix, sv = (SV*)newAV());
2172 else if (*name == '%')
2173 av_store(newpad, ix, sv = (SV*)newHV());
2175 av_store(newpad, ix, sv = NEWSV(0,0));
2180 av_store(newpad, ix, sv = NEWSV(0,0));
2184 if (cx->blk_sub.hasargs) {
2187 av_store(newpad, 0, (SV*)av);
2188 AvFLAGS(av) = AVf_REIFY;
2190 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2191 AvFILLp(padlist) = CvDEPTH(cv);
2192 svp = AvARRAY(padlist);
2196 if (!cx->blk_sub.hasargs) {
2197 AV* av = (AV*)PL_curpad[0];
2199 items = AvFILLp(av) + 1;
2201 /* Mark is at the end of the stack. */
2203 Copy(AvARRAY(av), SP + 1, items, SV*);
2208 #endif /* USE_THREADS */
2209 SAVESPTR(PL_curpad);
2210 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2212 if (cx->blk_sub.hasargs)
2213 #endif /* USE_THREADS */
2215 AV* av = (AV*)PL_curpad[0];
2219 cx->blk_sub.savearray = GvAV(PL_defgv);
2220 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2221 #endif /* USE_THREADS */
2222 cx->blk_sub.argarray = av;
2225 if (items >= AvMAX(av) + 1) {
2227 if (AvARRAY(av) != ary) {
2228 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2229 SvPVX(av) = (char*)ary;
2231 if (items >= AvMAX(av) + 1) {
2232 AvMAX(av) = items - 1;
2233 Renew(ary,items+1,SV*);
2235 SvPVX(av) = (char*)ary;
2238 Copy(mark,AvARRAY(av),items,SV*);
2239 AvFILLp(av) = items - 1;
2240 /* preserve @_ nature */
2251 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2253 * We do not care about using sv to call CV;
2254 * it's for informational purposes only.
2256 SV *sv = GvSV(PL_DBsub);
2259 if (PERLDB_SUB_NN) {
2260 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2263 gv_efullname3(sv, CvGV(cv), Nullch);
2266 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2267 PUSHMARK( PL_stack_sp );
2268 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2272 RETURNOP(CvSTART(cv));
2276 label = SvPV(sv,n_a);
2278 else if (PL_op->op_flags & OPf_SPECIAL) {
2280 DIE("goto must have label");
2283 label = cPVOP->op_pv;
2285 if (label && *label) {
2290 PL_lastgotoprobe = 0;
2292 for (ix = cxstack_ix; ix >= 0; ix--) {
2294 switch (CxTYPE(cx)) {
2296 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2299 gotoprobe = cx->blk_oldcop->op_sibling;
2305 gotoprobe = cx->blk_oldcop->op_sibling;
2307 gotoprobe = PL_main_root;
2310 if (CvDEPTH(cx->blk_sub.cv)) {
2311 gotoprobe = CvROOT(cx->blk_sub.cv);
2316 DIE("Can't \"goto\" outside a block");
2320 gotoprobe = PL_main_root;
2323 retop = dofindlabel(gotoprobe, label,
2324 enterops, enterops + GOTO_DEPTH);
2327 PL_lastgotoprobe = gotoprobe;
2330 DIE("Can't find label %s", label);
2332 /* pop unwanted frames */
2334 if (ix < cxstack_ix) {
2341 oldsave = PL_scopestack[PL_scopestack_ix];
2342 LEAVE_SCOPE(oldsave);
2345 /* push wanted frames */
2347 if (*enterops && enterops[1]) {
2349 for (ix = 1; enterops[ix]; ix++) {
2350 PL_op = enterops[ix];
2351 /* Eventually we may want to stack the needed arguments
2352 * for each op. For now, we punt on the hard ones. */
2353 if (PL_op->op_type == OP_ENTERITER)
2354 DIE("Can't \"goto\" into the middle of a foreach loop",
2356 (CALLOP->op_ppaddr)(ARGS);
2364 if (!retop) retop = PL_main_start;
2366 PL_restartop = retop;
2367 PL_do_undump = TRUE;
2371 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2372 PL_do_undump = FALSE;
2388 if (anum == 1 && VMSISH_EXIT)
2393 PUSHs(&PL_sv_undef);
2401 double value = SvNVx(GvSV(cCOP->cop_gv));
2402 register I32 match = I_32(value);
2405 if (((double)match) > value)
2406 --match; /* was fractional--truncate other way */
2408 match -= cCOP->uop.scop.scop_offset;
2411 else if (match > cCOP->uop.scop.scop_max)
2412 match = cCOP->uop.scop.scop_max;
2413 PL_op = cCOP->uop.scop.scop_next[match];
2423 PL_op = PL_op->op_next; /* can't assume anything */
2426 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2427 match -= cCOP->uop.scop.scop_offset;
2430 else if (match > cCOP->uop.scop.scop_max)
2431 match = cCOP->uop.scop.scop_max;
2432 PL_op = cCOP->uop.scop.scop_next[match];
2441 save_lines(AV *array, SV *sv)
2443 register char *s = SvPVX(sv);
2444 register char *send = SvPVX(sv) + SvCUR(sv);
2446 register I32 line = 1;
2448 while (s && s < send) {
2449 SV *tmpstr = NEWSV(85,0);
2451 sv_upgrade(tmpstr, SVt_PVMG);
2452 t = strchr(s, '\n');
2458 sv_setpvn(tmpstr, s, t - s);
2459 av_store(array, line++, tmpstr);
2474 assert(CATCH_GET == TRUE);
2475 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2479 default: /* topmost level handles it */
2488 PL_op = PL_restartop;
2501 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2502 /* sv Text to convert to OP tree. */
2503 /* startop op_free() this to undo. */
2504 /* code Short string id of the caller. */
2506 dSP; /* Make POPBLOCK work. */
2509 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2512 OP *oop = PL_op, *rop;
2513 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2519 /* switch to eval mode */
2521 if (PL_curcop == &PL_compiling) {
2522 SAVESPTR(PL_compiling.cop_stash);
2523 PL_compiling.cop_stash = PL_curstash;
2525 SAVESPTR(PL_compiling.cop_filegv);
2526 SAVEI16(PL_compiling.cop_line);
2527 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2528 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2529 PL_compiling.cop_line = 1;
2530 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2531 deleting the eval's FILEGV from the stash before gv_check() runs
2532 (i.e. before run-time proper). To work around the coredump that
2533 ensues, we always turn GvMULTI_on for any globals that were
2534 introduced within evals. See force_ident(). GSAR 96-10-12 */
2535 safestr = savepv(tmpbuf);
2536 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2538 #ifdef OP_IN_REGISTER
2546 PL_op->op_type = OP_ENTEREVAL;
2547 PL_op->op_flags = 0; /* Avoid uninit warning. */
2548 PUSHBLOCK(cx, CXt_EVAL, SP);
2549 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2550 rop = doeval(G_SCALAR, startop);
2551 POPBLOCK(cx,PL_curpm);
2554 (*startop)->op_type = OP_NULL;
2555 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2557 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2559 if (PL_curcop == &PL_compiling)
2560 PL_compiling.op_private = PL_hints;
2561 #ifdef OP_IN_REGISTER
2567 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2569 doeval(int gimme, OP** startop)
2582 /* set up a scratch pad */
2585 SAVESPTR(PL_curpad);
2586 SAVESPTR(PL_comppad);
2587 SAVESPTR(PL_comppad_name);
2588 SAVEI32(PL_comppad_name_fill);
2589 SAVEI32(PL_min_intro_pending);
2590 SAVEI32(PL_max_intro_pending);
2593 for (i = cxstack_ix - 1; i >= 0; i--) {
2594 PERL_CONTEXT *cx = &cxstack[i];
2595 if (CxTYPE(cx) == CXt_EVAL)
2597 else if (CxTYPE(cx) == CXt_SUB) {
2598 caller = cx->blk_sub.cv;
2603 SAVESPTR(PL_compcv);
2604 PL_compcv = (CV*)NEWSV(1104,0);
2605 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2606 CvUNIQUE_on(PL_compcv);
2608 CvOWNER(PL_compcv) = 0;
2609 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2610 MUTEX_INIT(CvMUTEXP(PL_compcv));
2611 #endif /* USE_THREADS */
2613 PL_comppad = newAV();
2614 av_push(PL_comppad, Nullsv);
2615 PL_curpad = AvARRAY(PL_comppad);
2616 PL_comppad_name = newAV();
2617 PL_comppad_name_fill = 0;
2618 PL_min_intro_pending = 0;
2621 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2622 PL_curpad[0] = (SV*)newAV();
2623 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2624 #endif /* USE_THREADS */
2626 comppadlist = newAV();
2627 AvREAL_off(comppadlist);
2628 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2629 av_store(comppadlist, 1, (SV*)PL_comppad);
2630 CvPADLIST(PL_compcv) = comppadlist;
2632 if (!saveop || saveop->op_type != OP_REQUIRE)
2633 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2635 SAVEFREESV(PL_compcv);
2637 /* make sure we compile in the right package */
2639 newstash = PL_curcop->cop_stash;
2640 if (PL_curstash != newstash) {
2641 SAVESPTR(PL_curstash);
2642 PL_curstash = newstash;
2644 SAVESPTR(PL_beginav);
2645 PL_beginav = newAV();
2646 SAVEFREESV(PL_beginav);
2648 /* try to compile it */
2650 PL_eval_root = Nullop;
2652 PL_curcop = &PL_compiling;
2653 PL_curcop->cop_arybase = 0;
2654 SvREFCNT_dec(PL_rs);
2655 PL_rs = newSVpv("\n", 1);
2656 if (saveop && saveop->op_flags & OPf_SPECIAL)
2660 if (yyparse() || PL_error_count || !PL_eval_root) {
2664 I32 optype = 0; /* Might be reset by POPEVAL. */
2669 op_free(PL_eval_root);
2670 PL_eval_root = Nullop;
2672 SP = PL_stack_base + POPMARK; /* pop original mark */
2674 POPBLOCK(cx,PL_curpm);
2680 if (optype == OP_REQUIRE) {
2681 char* msg = SvPVx(ERRSV, n_a);
2682 DIE("%s", *msg ? msg : "Compilation failed in require");
2683 } else if (startop) {
2684 char* msg = SvPVx(ERRSV, n_a);
2686 POPBLOCK(cx,PL_curpm);
2688 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2690 SvREFCNT_dec(PL_rs);
2691 PL_rs = SvREFCNT_inc(PL_nrs);
2693 MUTEX_LOCK(&PL_eval_mutex);
2695 COND_SIGNAL(&PL_eval_cond);
2696 MUTEX_UNLOCK(&PL_eval_mutex);
2697 #endif /* USE_THREADS */
2700 SvREFCNT_dec(PL_rs);
2701 PL_rs = SvREFCNT_inc(PL_nrs);
2702 PL_compiling.cop_line = 0;
2704 *startop = PL_eval_root;
2705 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2706 CvOUTSIDE(PL_compcv) = Nullcv;
2708 SAVEFREEOP(PL_eval_root);
2710 scalarvoid(PL_eval_root);
2711 else if (gimme & G_ARRAY)
2714 scalar(PL_eval_root);
2716 DEBUG_x(dump_eval());
2718 /* Register with debugger: */
2719 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2720 CV *cv = perl_get_cv("DB::postponed", FALSE);
2724 XPUSHs((SV*)PL_compiling.cop_filegv);
2726 perl_call_sv((SV*)cv, G_DISCARD);
2730 /* compiled okay, so do it */
2732 CvDEPTH(PL_compcv) = 1;
2733 SP = PL_stack_base + POPMARK; /* pop original mark */
2734 PL_op = saveop; /* The caller may need it. */
2736 MUTEX_LOCK(&PL_eval_mutex);
2738 COND_SIGNAL(&PL_eval_cond);
2739 MUTEX_UNLOCK(&PL_eval_mutex);
2740 #endif /* USE_THREADS */
2742 RETURNOP(PL_eval_start);
2748 register PERL_CONTEXT *cx;
2753 SV *namesv = Nullsv;
2755 I32 gimme = G_SCALAR;
2756 PerlIO *tryrsfp = 0;
2760 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2761 SET_NUMERIC_STANDARD();
2762 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2763 DIE("Perl %s required--this is only version %s, stopped",
2764 SvPV(sv,n_a),PL_patchlevel);
2767 name = SvPV(sv, len);
2768 if (!(name && len > 0 && *name))
2769 DIE("Null filename used");
2770 TAINT_PROPER("require");
2771 if (PL_op->op_type == OP_REQUIRE &&
2772 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2773 *svp != &PL_sv_undef)
2776 /* prepare to compile file */
2781 (name[1] == '.' && name[2] == '/')))
2783 || (name[0] && name[1] == ':')
2786 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2789 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2790 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2795 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2798 AV *ar = GvAVn(PL_incgv);
2802 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2805 namesv = NEWSV(806, 0);
2806 for (i = 0; i <= AvFILL(ar); i++) {
2807 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2810 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2812 sv_setpv(namesv, unixdir);
2813 sv_catpv(namesv, unixname);
2815 sv_setpvf(namesv, "%s/%s", dir, name);
2817 TAINT_PROPER("require");
2818 tryname = SvPVX(namesv);
2819 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2821 if (tryname[0] == '.' && tryname[1] == '/')
2828 SAVESPTR(PL_compiling.cop_filegv);
2829 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2830 SvREFCNT_dec(namesv);
2832 if (PL_op->op_type == OP_REQUIRE) {
2833 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2834 SV *dirmsgsv = NEWSV(0, 0);
2835 AV *ar = GvAVn(PL_incgv);
2837 if (instr(SvPVX(msg), ".h "))
2838 sv_catpv(msg, " (change .h to .ph maybe?)");
2839 if (instr(SvPVX(msg), ".ph "))
2840 sv_catpv(msg, " (did you run h2ph?)");
2841 sv_catpv(msg, " (@INC contains:");
2842 for (i = 0; i <= AvFILL(ar); i++) {
2843 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2844 sv_setpvf(dirmsgsv, " %s", dir);
2845 sv_catsv(msg, dirmsgsv);
2847 sv_catpvn(msg, ")", 1);
2848 SvREFCNT_dec(dirmsgsv);
2855 SETERRNO(0, SS$_NORMAL);
2857 /* Assume success here to prevent recursive requirement. */
2858 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2859 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2863 lex_start(sv_2mortal(newSVpv("",0)));
2864 SAVEGENERICSV(PL_rsfp_filters);
2865 PL_rsfp_filters = Nullav;
2868 name = savepv(name);
2872 SAVEPPTR(PL_compiling.cop_warnings);
2873 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2876 /* switch to eval mode */
2878 push_return(PL_op->op_next);
2879 PUSHBLOCK(cx, CXt_EVAL, SP);
2880 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2882 SAVEI16(PL_compiling.cop_line);
2883 PL_compiling.cop_line = 0;
2887 MUTEX_LOCK(&PL_eval_mutex);
2888 if (PL_eval_owner && PL_eval_owner != thr)
2889 while (PL_eval_owner)
2890 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2891 PL_eval_owner = thr;
2892 MUTEX_UNLOCK(&PL_eval_mutex);
2893 #endif /* USE_THREADS */
2894 return DOCATCH(doeval(G_SCALAR, NULL));
2899 return pp_require(ARGS);
2905 register PERL_CONTEXT *cx;
2907 I32 gimme = GIMME_V, was = PL_sub_generation;
2908 char tmpbuf[TYPE_DIGITS(long) + 12];
2913 if (!SvPV(sv,len) || !len)
2915 TAINT_PROPER("eval");
2921 /* switch to eval mode */
2923 SAVESPTR(PL_compiling.cop_filegv);
2924 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2925 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2926 PL_compiling.cop_line = 1;
2927 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2928 deleting the eval's FILEGV from the stash before gv_check() runs
2929 (i.e. before run-time proper). To work around the coredump that
2930 ensues, we always turn GvMULTI_on for any globals that were
2931 introduced within evals. See force_ident(). GSAR 96-10-12 */
2932 safestr = savepv(tmpbuf);
2933 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2935 PL_hints = PL_op->op_targ;
2936 SAVEPPTR(PL_compiling.cop_warnings);
2937 if (PL_compiling.cop_warnings != WARN_ALL
2938 && PL_compiling.cop_warnings != WARN_NONE){
2939 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2940 SAVEFREESV(PL_compiling.cop_warnings) ;
2943 push_return(PL_op->op_next);
2944 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2945 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2947 /* prepare to compile string */
2949 if (PERLDB_LINE && PL_curstash != PL_debstash)
2950 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2953 MUTEX_LOCK(&PL_eval_mutex);
2954 if (PL_eval_owner && PL_eval_owner != thr)
2955 while (PL_eval_owner)
2956 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2957 PL_eval_owner = thr;
2958 MUTEX_UNLOCK(&PL_eval_mutex);
2959 #endif /* USE_THREADS */
2960 ret = doeval(gimme, NULL);
2961 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2962 && ret != PL_op->op_next) { /* Successive compilation. */
2963 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2965 return DOCATCH(ret);
2975 register PERL_CONTEXT *cx;
2977 U8 save_flags = PL_op -> op_flags;
2982 retop = pop_return();
2985 if (gimme == G_VOID)
2987 else if (gimme == G_SCALAR) {
2990 if (SvFLAGS(TOPs) & SVs_TEMP)
2993 *MARK = sv_mortalcopy(TOPs);
2997 *MARK = &PL_sv_undef;
3001 /* in case LEAVE wipes old return values */
3002 for (mark = newsp + 1; mark <= SP; mark++) {
3003 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3004 *mark = sv_mortalcopy(*mark);
3005 TAINT_NOT; /* Each item is independent */
3009 PL_curpm = newpm; /* Don't pop $1 et al till now */
3012 * Closures mentioned at top level of eval cannot be referenced
3013 * again, and their presence indirectly causes a memory leak.
3014 * (Note that the fact that compcv and friends are still set here
3015 * is, AFAIK, an accident.) --Chip
3017 if (AvFILLp(PL_comppad_name) >= 0) {
3018 SV **svp = AvARRAY(PL_comppad_name);
3020 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3022 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3024 svp[ix] = &PL_sv_undef;
3028 SvREFCNT_dec(CvOUTSIDE(sv));
3029 CvOUTSIDE(sv) = Nullcv;
3042 assert(CvDEPTH(PL_compcv) == 1);
3044 CvDEPTH(PL_compcv) = 0;
3047 if (optype == OP_REQUIRE &&
3048 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3050 /* Unassume the success we assumed earlier. */
3051 char *name = cx->blk_eval.old_name;
3052 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3053 retop = die("%s did not return a true value", name);
3054 /* die_where() did LEAVE, or we won't be here */
3058 if (!(save_flags & OPf_SPECIAL))
3068 register PERL_CONTEXT *cx;
3069 I32 gimme = GIMME_V;
3074 push_return(cLOGOP->op_other->op_next);
3075 PUSHBLOCK(cx, CXt_EVAL, SP);
3077 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3082 return DOCATCH(PL_op->op_next);
3092 register PERL_CONTEXT *cx;
3100 if (gimme == G_VOID)
3102 else if (gimme == G_SCALAR) {
3105 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3108 *MARK = sv_mortalcopy(TOPs);
3112 *MARK = &PL_sv_undef;
3117 /* in case LEAVE wipes old return values */
3118 for (mark = newsp + 1; mark <= SP; mark++) {
3119 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3120 *mark = sv_mortalcopy(*mark);
3121 TAINT_NOT; /* Each item is independent */
3125 PL_curpm = newpm; /* Don't pop $1 et al till now */
3136 register char *s = SvPV_force(sv, len);
3137 register char *send = s + len;
3138 register char *base;
3139 register I32 skipspaces = 0;
3142 bool postspace = FALSE;
3150 croak("Null picture in formline");
3152 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3157 *fpc++ = FF_LINEMARK;
3158 noblank = repeat = FALSE;
3176 case ' ': case '\t':
3187 *fpc++ = FF_LITERAL;
3195 *fpc++ = skipspaces;
3199 *fpc++ = FF_NEWLINE;
3203 arg = fpc - linepc + 1;
3210 *fpc++ = FF_LINEMARK;
3211 noblank = repeat = FALSE;
3220 ischop = s[-1] == '^';
3226 arg = (s - base) - 1;
3228 *fpc++ = FF_LITERAL;
3237 *fpc++ = FF_LINEGLOB;
3239 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3240 arg = ischop ? 512 : 0;
3250 arg |= 256 + (s - f);
3252 *fpc++ = s - base; /* fieldsize for FETCH */
3253 *fpc++ = FF_DECIMAL;
3258 bool ismore = FALSE;
3261 while (*++s == '>') ;
3262 prespace = FF_SPACE;
3264 else if (*s == '|') {
3265 while (*++s == '|') ;
3266 prespace = FF_HALFSPACE;
3271 while (*++s == '<') ;
3274 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3278 *fpc++ = s - base; /* fieldsize for FETCH */
3280 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3298 { /* need to jump to the next word */
3300 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3301 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3302 s = SvPVX(sv) + SvCUR(sv) + z;
3304 Copy(fops, s, arg, U16);
3306 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3311 * The rest of this file was derived from source code contributed
3314 * NOTE: this code was derived from Tom Horsley's qsort replacement
3315 * and should not be confused with the original code.
3318 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3320 Permission granted to distribute under the same terms as perl which are
3323 This program is free software; you can redistribute it and/or modify
3324 it under the terms of either:
3326 a) the GNU General Public License as published by the Free
3327 Software Foundation; either version 1, or (at your option) any
3330 b) the "Artistic License" which comes with this Kit.
3332 Details on the perl license can be found in the perl source code which
3333 may be located via the www.perl.com web page.
3335 This is the most wonderfulest possible qsort I can come up with (and
3336 still be mostly portable) My (limited) tests indicate it consistently
3337 does about 20% fewer calls to compare than does the qsort in the Visual
3338 C++ library, other vendors may vary.
3340 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3341 others I invented myself (or more likely re-invented since they seemed
3342 pretty obvious once I watched the algorithm operate for a while).
3344 Most of this code was written while watching the Marlins sweep the Giants
3345 in the 1997 National League Playoffs - no Braves fans allowed to use this
3346 code (just kidding :-).
3348 I realize that if I wanted to be true to the perl tradition, the only
3349 comment in this file would be something like:
3351 ...they shuffled back towards the rear of the line. 'No, not at the
3352 rear!' the slave-driver shouted. 'Three files up. And stay there...
3354 However, I really needed to violate that tradition just so I could keep
3355 track of what happens myself, not to mention some poor fool trying to
3356 understand this years from now :-).
3359 /* ********************************************************** Configuration */
3361 #ifndef QSORT_ORDER_GUESS
3362 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3365 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3366 future processing - a good max upper bound is log base 2 of memory size
3367 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3368 safely be smaller than that since the program is taking up some space and
3369 most operating systems only let you grab some subset of contiguous
3370 memory (not to mention that you are normally sorting data larger than
3371 1 byte element size :-).
3373 #ifndef QSORT_MAX_STACK
3374 #define QSORT_MAX_STACK 32
3377 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3378 Anything bigger and we use qsort. If you make this too small, the qsort
3379 will probably break (or become less efficient), because it doesn't expect
3380 the middle element of a partition to be the same as the right or left -
3381 you have been warned).
3383 #ifndef QSORT_BREAK_EVEN
3384 #define QSORT_BREAK_EVEN 6
3387 /* ************************************************************* Data Types */
3389 /* hold left and right index values of a partition waiting to be sorted (the
3390 partition includes both left and right - right is NOT one past the end or
3391 anything like that).
3393 struct partition_stack_entry {
3396 #ifdef QSORT_ORDER_GUESS
3397 int qsort_break_even;
3401 /* ******************************************************* Shorthand Macros */
3403 /* Note that these macros will be used from inside the qsort function where
3404 we happen to know that the variable 'elt_size' contains the size of an
3405 array element and the variable 'temp' points to enough space to hold a
3406 temp element and the variable 'array' points to the array being sorted
3407 and 'compare' is the pointer to the compare routine.
3409 Also note that there are very many highly architecture specific ways
3410 these might be sped up, but this is simply the most generally portable
3411 code I could think of.
3414 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3417 #define qsort_cmp(elt1, elt2) \
3418 ((this->*compare)(array[elt1], array[elt2]))
3420 #define qsort_cmp(elt1, elt2) \
3421 ((*compare)(array[elt1], array[elt2]))
3424 #ifdef QSORT_ORDER_GUESS
3425 #define QSORT_NOTICE_SWAP swapped++;
3427 #define QSORT_NOTICE_SWAP
3430 /* swaps contents of array elements elt1, elt2.
3432 #define qsort_swap(elt1, elt2) \
3435 temp = array[elt1]; \
3436 array[elt1] = array[elt2]; \
3437 array[elt2] = temp; \
3440 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3441 elt3 and elt3 gets elt1.
3443 #define qsort_rotate(elt1, elt2, elt3) \
3446 temp = array[elt1]; \
3447 array[elt1] = array[elt2]; \
3448 array[elt2] = array[elt3]; \
3449 array[elt3] = temp; \
3452 /* ************************************************************ Debug stuff */
3459 return; /* good place to set a breakpoint */
3462 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3465 doqsort_all_asserts(
3469 int (*compare)(const void * elt1, const void * elt2),
3470 int pc_left, int pc_right, int u_left, int u_right)
3474 qsort_assert(pc_left <= pc_right);
3475 qsort_assert(u_right < pc_left);
3476 qsort_assert(pc_right < u_left);
3477 for (i = u_right + 1; i < pc_left; ++i) {
3478 qsort_assert(qsort_cmp(i, pc_left) < 0);
3480 for (i = pc_left; i < pc_right; ++i) {
3481 qsort_assert(qsort_cmp(i, pc_right) == 0);
3483 for (i = pc_right + 1; i < u_left; ++i) {
3484 qsort_assert(qsort_cmp(pc_right, i) < 0);
3488 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3489 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3490 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3494 #define qsort_assert(t) ((void)0)
3496 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3500 /* ****************************************************************** qsort */
3504 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3509 I32 (*compare)(SV *a, SV *b))
3514 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3515 int next_stack_entry = 0;
3519 #ifdef QSORT_ORDER_GUESS
3520 int qsort_break_even;
3524 /* Make sure we actually have work to do.
3526 if (num_elts <= 1) {
3530 /* Setup the initial partition definition and fall into the sorting loop
3533 part_right = (int)(num_elts - 1);
3534 #ifdef QSORT_ORDER_GUESS
3535 qsort_break_even = QSORT_BREAK_EVEN;
3537 #define qsort_break_even QSORT_BREAK_EVEN
3540 if ((part_right - part_left) >= qsort_break_even) {
3541 /* OK, this is gonna get hairy, so lets try to document all the
3542 concepts and abbreviations and variables and what they keep
3545 pc: pivot chunk - the set of array elements we accumulate in the
3546 middle of the partition, all equal in value to the original
3547 pivot element selected. The pc is defined by:
3549 pc_left - the leftmost array index of the pc
3550 pc_right - the rightmost array index of the pc
3552 we start with pc_left == pc_right and only one element
3553 in the pivot chunk (but it can grow during the scan).
3555 u: uncompared elements - the set of elements in the partition
3556 we have not yet compared to the pivot value. There are two
3557 uncompared sets during the scan - one to the left of the pc
3558 and one to the right.
3560 u_right - the rightmost index of the left side's uncompared set
3561 u_left - the leftmost index of the right side's uncompared set
3563 The leftmost index of the left sides's uncompared set
3564 doesn't need its own variable because it is always defined
3565 by the leftmost edge of the whole partition (part_left). The
3566 same goes for the rightmost edge of the right partition
3569 We know there are no uncompared elements on the left once we
3570 get u_right < part_left and no uncompared elements on the
3571 right once u_left > part_right. When both these conditions
3572 are met, we have completed the scan of the partition.
3574 Any elements which are between the pivot chunk and the
3575 uncompared elements should be less than the pivot value on
3576 the left side and greater than the pivot value on the right
3577 side (in fact, the goal of the whole algorithm is to arrange
3578 for that to be true and make the groups of less-than and
3579 greater-then elements into new partitions to sort again).
3581 As you marvel at the complexity of the code and wonder why it
3582 has to be so confusing. Consider some of the things this level
3583 of confusion brings:
3585 Once I do a compare, I squeeze every ounce of juice out of it. I
3586 never do compare calls I don't have to do, and I certainly never
3589 I also never swap any elements unless I can prove there is a
3590 good reason. Many sort algorithms will swap a known value with
3591 an uncompared value just to get things in the right place (or
3592 avoid complexity :-), but that uncompared value, once it gets
3593 compared, may then have to be swapped again. A lot of the
3594 complexity of this code is due to the fact that it never swaps
3595 anything except compared values, and it only swaps them when the
3596 compare shows they are out of position.
3598 int pc_left, pc_right;
3599 int u_right, u_left;
3603 pc_left = ((part_left + part_right) / 2);
3605 u_right = pc_left - 1;
3606 u_left = pc_right + 1;
3608 /* Qsort works best when the pivot value is also the median value
3609 in the partition (unfortunately you can't find the median value
3610 without first sorting :-), so to give the algorithm a helping
3611 hand, we pick 3 elements and sort them and use the median value
3612 of that tiny set as the pivot value.
3614 Some versions of qsort like to use the left middle and right as
3615 the 3 elements to sort so they can insure the ends of the
3616 partition will contain values which will stop the scan in the
3617 compare loop, but when you have to call an arbitrarily complex
3618 routine to do a compare, its really better to just keep track of
3619 array index values to know when you hit the edge of the
3620 partition and avoid the extra compare. An even better reason to
3621 avoid using a compare call is the fact that you can drop off the
3622 edge of the array if someone foolishly provides you with an
3623 unstable compare function that doesn't always provide consistent
3626 So, since it is simpler for us to compare the three adjacent
3627 elements in the middle of the partition, those are the ones we
3628 pick here (conveniently pointed at by u_right, pc_left, and
3629 u_left). The values of the left, center, and right elements
3630 are refered to as l c and r in the following comments.
3633 #ifdef QSORT_ORDER_GUESS
3636 s = qsort_cmp(u_right, pc_left);
3639 s = qsort_cmp(pc_left, u_left);
3640 /* if l < c, c < r - already in order - nothing to do */
3642 /* l < c, c == r - already in order, pc grows */
3644 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3646 /* l < c, c > r - need to know more */
3647 s = qsort_cmp(u_right, u_left);
3649 /* l < c, c > r, l < r - swap c & r to get ordered */
3650 qsort_swap(pc_left, u_left);
3651 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3652 } else if (s == 0) {
3653 /* l < c, c > r, l == r - swap c&r, grow pc */
3654 qsort_swap(pc_left, u_left);
3656 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3658 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3659 qsort_rotate(pc_left, u_right, u_left);
3660 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3663 } else if (s == 0) {
3665 s = qsort_cmp(pc_left, u_left);
3667 /* l == c, c < r - already in order, grow pc */
3669 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3670 } else if (s == 0) {
3671 /* l == c, c == r - already in order, grow pc both ways */
3674 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3676 /* l == c, c > r - swap l & r, grow pc */
3677 qsort_swap(u_right, u_left);
3679 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3683 s = qsort_cmp(pc_left, u_left);
3685 /* l > c, c < r - need to know more */
3686 s = qsort_cmp(u_right, u_left);
3688 /* l > c, c < r, l < r - swap l & c to get ordered */
3689 qsort_swap(u_right, pc_left);
3690 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3691 } else if (s == 0) {
3692 /* l > c, c < r, l == r - swap l & c, grow pc */
3693 qsort_swap(u_right, pc_left);
3695 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3697 /* l > c, c < r, l > r - rotate lcr into crl to order */
3698 qsort_rotate(u_right, pc_left, u_left);
3699 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3701 } else if (s == 0) {
3702 /* l > c, c == r - swap ends, grow pc */
3703 qsort_swap(u_right, u_left);
3705 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3707 /* l > c, c > r - swap ends to get in order */
3708 qsort_swap(u_right, u_left);
3709 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3712 /* We now know the 3 middle elements have been compared and
3713 arranged in the desired order, so we can shrink the uncompared
3718 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3720 /* The above massive nested if was the simple part :-). We now have
3721 the middle 3 elements ordered and we need to scan through the
3722 uncompared sets on either side, swapping elements that are on
3723 the wrong side or simply shuffling equal elements around to get
3724 all equal elements into the pivot chunk.
3728 int still_work_on_left;
3729 int still_work_on_right;
3731 /* Scan the uncompared values on the left. If I find a value
3732 equal to the pivot value, move it over so it is adjacent to
3733 the pivot chunk and expand the pivot chunk. If I find a value
3734 less than the pivot value, then just leave it - its already
3735 on the correct side of the partition. If I find a greater
3736 value, then stop the scan.
3738 while (still_work_on_left = (u_right >= part_left)) {
3739 s = qsort_cmp(u_right, pc_left);
3742 } else if (s == 0) {
3744 if (pc_left != u_right) {
3745 qsort_swap(u_right, pc_left);
3751 qsort_assert(u_right < pc_left);
3752 qsort_assert(pc_left <= pc_right);
3753 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3754 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3757 /* Do a mirror image scan of uncompared values on the right
3759 while (still_work_on_right = (u_left <= part_right)) {
3760 s = qsort_cmp(pc_right, u_left);
3763 } else if (s == 0) {
3765 if (pc_right != u_left) {
3766 qsort_swap(pc_right, u_left);
3772 qsort_assert(u_left > pc_right);
3773 qsort_assert(pc_left <= pc_right);
3774 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3775 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3778 if (still_work_on_left) {
3779 /* I know I have a value on the left side which needs to be
3780 on the right side, but I need to know more to decide
3781 exactly the best thing to do with it.
3783 if (still_work_on_right) {
3784 /* I know I have values on both side which are out of
3785 position. This is a big win because I kill two birds
3786 with one swap (so to speak). I can advance the
3787 uncompared pointers on both sides after swapping both
3788 of them into the right place.
3790 qsort_swap(u_right, u_left);
3793 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3795 /* I have an out of position value on the left, but the
3796 right is fully scanned, so I "slide" the pivot chunk
3797 and any less-than values left one to make room for the
3798 greater value over on the right. If the out of position
3799 value is immediately adjacent to the pivot chunk (there
3800 are no less-than values), I can do that with a swap,
3801 otherwise, I have to rotate one of the less than values
3802 into the former position of the out of position value
3803 and the right end of the pivot chunk into the left end
3807 if (pc_left == u_right) {
3808 qsort_swap(u_right, pc_right);
3809 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3811 qsort_rotate(u_right, pc_left, pc_right);
3812 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3817 } else if (still_work_on_right) {
3818 /* Mirror image of complex case above: I have an out of
3819 position value on the right, but the left is fully
3820 scanned, so I need to shuffle things around to make room
3821 for the right value on the left.
3824 if (pc_right == u_left) {
3825 qsort_swap(u_left, pc_left);
3826 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3828 qsort_rotate(pc_right, pc_left, u_left);
3829 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3834 /* No more scanning required on either side of partition,
3835 break out of loop and figure out next set of partitions
3841 /* The elements in the pivot chunk are now in the right place. They
3842 will never move or be compared again. All I have to do is decide
3843 what to do with the stuff to the left and right of the pivot
3846 Notes on the QSORT_ORDER_GUESS ifdef code:
3848 1. If I just built these partitions without swapping any (or
3849 very many) elements, there is a chance that the elements are
3850 already ordered properly (being properly ordered will
3851 certainly result in no swapping, but the converse can't be
3854 2. A (properly written) insertion sort will run faster on
3855 already ordered data than qsort will.
3857 3. Perhaps there is some way to make a good guess about
3858 switching to an insertion sort earlier than partition size 6
3859 (for instance - we could save the partition size on the stack
3860 and increase the size each time we find we didn't swap, thus
3861 switching to insertion sort earlier for partitions with a
3862 history of not swapping).
3864 4. Naturally, if I just switch right away, it will make
3865 artificial benchmarks with pure ascending (or descending)
3866 data look really good, but is that a good reason in general?
3870 #ifdef QSORT_ORDER_GUESS
3872 #if QSORT_ORDER_GUESS == 1
3873 qsort_break_even = (part_right - part_left) + 1;
3875 #if QSORT_ORDER_GUESS == 2
3876 qsort_break_even *= 2;
3878 #if QSORT_ORDER_GUESS == 3
3879 int prev_break = qsort_break_even;
3880 qsort_break_even *= qsort_break_even;
3881 if (qsort_break_even < prev_break) {
3882 qsort_break_even = (part_right - part_left) + 1;
3886 qsort_break_even = QSORT_BREAK_EVEN;
3890 if (part_left < pc_left) {
3891 /* There are elements on the left which need more processing.
3892 Check the right as well before deciding what to do.
3894 if (pc_right < part_right) {
3895 /* We have two partitions to be sorted. Stack the biggest one
3896 and process the smallest one on the next iteration. This
3897 minimizes the stack height by insuring that any additional
3898 stack entries must come from the smallest partition which
3899 (because it is smallest) will have the fewest
3900 opportunities to generate additional stack entries.
3902 if ((part_right - pc_right) > (pc_left - part_left)) {
3903 /* stack the right partition, process the left */
3904 partition_stack[next_stack_entry].left = pc_right + 1;
3905 partition_stack[next_stack_entry].right = part_right;
3906 #ifdef QSORT_ORDER_GUESS
3907 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3909 part_right = pc_left - 1;
3911 /* stack the left partition, process the right */
3912 partition_stack[next_stack_entry].left = part_left;
3913 partition_stack[next_stack_entry].right = pc_left - 1;
3914 #ifdef QSORT_ORDER_GUESS
3915 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3917 part_left = pc_right + 1;
3919 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3922 /* The elements on the left are the only remaining elements
3923 that need sorting, arrange for them to be processed as the
3926 part_right = pc_left - 1;
3928 } else if (pc_right < part_right) {
3929 /* There is only one chunk on the right to be sorted, make it
3930 the new partition and loop back around.
3932 part_left = pc_right + 1;
3934 /* This whole partition wound up in the pivot chunk, so
3935 we need to get a new partition off the stack.
3937 if (next_stack_entry == 0) {
3938 /* the stack is empty - we are done */
3942 part_left = partition_stack[next_stack_entry].left;
3943 part_right = partition_stack[next_stack_entry].right;
3944 #ifdef QSORT_ORDER_GUESS
3945 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3949 /* This partition is too small to fool with qsort complexity, just
3950 do an ordinary insertion sort to minimize overhead.
3953 /* Assume 1st element is in right place already, and start checking
3954 at 2nd element to see where it should be inserted.
3956 for (i = part_left + 1; i <= part_right; ++i) {
3958 /* Scan (backwards - just in case 'i' is already in right place)
3959 through the elements already sorted to see if the ith element
3960 belongs ahead of one of them.
3962 for (j = i - 1; j >= part_left; --j) {
3963 if (qsort_cmp(i, j) >= 0) {
3964 /* i belongs right after j
3971 /* Looks like we really need to move some things
3975 for (k = i - 1; k >= j; --k)
3976 array[k + 1] = array[k];
3981 /* That partition is now sorted, grab the next one, or get out
3982 of the loop if there aren't any more.
3985 if (next_stack_entry == 0) {
3986 /* the stack is empty - we are done */
3990 part_left = partition_stack[next_stack_entry].left;
3991 part_right = partition_stack[next_stack_entry].right;
3992 #ifdef QSORT_ORDER_GUESS
3993 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3998 /* Believe it or not, the array is sorted at this point! */