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 static I32 amagic_cmp _((SV *str1, SV *str2));
49 static 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");
1087 sv = sv_2mortal(newSViv(i++));
1092 SV *final = sv_mortalcopy(right);
1094 char *tmps = SvPV(final, len);
1096 sv = sv_mortalcopy(left);
1098 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1100 if (strEQ(SvPVX(sv),tmps))
1102 sv = sv_2mortal(newSVsv(sv));
1109 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1111 if ((PL_op->op_private & OPpFLIP_LINENUM)
1112 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1114 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1115 sv_catpv(targ, "E0");
1126 dopoptolabel(char *label)
1130 register PERL_CONTEXT *cx;
1132 for (i = cxstack_ix; i >= 0; i--) {
1134 switch (CxTYPE(cx)) {
1136 if (ckWARN(WARN_UNSAFE))
1137 warner(WARN_UNSAFE, "Exiting substitution via %s",
1138 PL_op_name[PL_op->op_type]);
1141 if (ckWARN(WARN_UNSAFE))
1142 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1143 PL_op_name[PL_op->op_type]);
1146 if (ckWARN(WARN_UNSAFE))
1147 warner(WARN_UNSAFE, "Exiting eval via %s",
1148 PL_op_name[PL_op->op_type]);
1151 if (ckWARN(WARN_UNSAFE))
1152 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1153 PL_op_name[PL_op->op_type]);
1156 if (!cx->blk_loop.label ||
1157 strNE(label, cx->blk_loop.label) ) {
1158 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1159 (long)i, cx->blk_loop.label));
1162 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1172 I32 gimme = block_gimme();
1173 return (gimme == G_VOID) ? G_SCALAR : gimme;
1182 cxix = dopoptosub(cxstack_ix);
1186 switch (cxstack[cxix].blk_gimme) {
1194 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1201 dopoptosub(I32 startingblock)
1204 return dopoptosub_at(cxstack, startingblock);
1208 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1212 register PERL_CONTEXT *cx;
1213 for (i = startingblock; i >= 0; i--) {
1215 switch (CxTYPE(cx)) {
1220 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1228 dopoptoeval(I32 startingblock)
1232 register PERL_CONTEXT *cx;
1233 for (i = startingblock; i >= 0; i--) {
1235 switch (CxTYPE(cx)) {
1239 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1247 dopoptoloop(I32 startingblock)
1251 register PERL_CONTEXT *cx;
1252 for (i = startingblock; i >= 0; i--) {
1254 switch (CxTYPE(cx)) {
1256 if (ckWARN(WARN_UNSAFE))
1257 warner(WARN_UNSAFE, "Exiting substitution via %s",
1258 PL_op_name[PL_op->op_type]);
1261 if (ckWARN(WARN_UNSAFE))
1262 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1263 PL_op_name[PL_op->op_type]);
1266 if (ckWARN(WARN_UNSAFE))
1267 warner(WARN_UNSAFE, "Exiting eval via %s",
1268 PL_op_name[PL_op->op_type]);
1271 if (ckWARN(WARN_UNSAFE))
1272 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1273 PL_op_name[PL_op->op_type]);
1276 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1287 register PERL_CONTEXT *cx;
1291 while (cxstack_ix > cxix) {
1292 cx = &cxstack[cxstack_ix];
1293 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1294 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1295 /* Note: we don't need to restore the base context info till the end. */
1296 switch (CxTYPE(cx)) {
1299 continue; /* not break */
1317 die_where(char *message)
1323 register PERL_CONTEXT *cx;
1328 if (PL_in_eval & 4) {
1330 STRLEN klen = strlen(message);
1332 svp = hv_fetch(ERRHV, message, klen, TRUE);
1335 static char prefix[] = "\t(in cleanup) ";
1337 sv_upgrade(*svp, SVt_IV);
1338 (void)SvIOK_only(*svp);
1341 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1342 sv_catpvn(err, prefix, sizeof(prefix)-1);
1343 sv_catpvn(err, message, klen);
1344 if (ckWARN(WARN_UNSAFE)) {
1345 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1346 warner(WARN_UNSAFE, SvPVX(err)+start);
1353 sv_setpv(ERRSV, message);
1356 message = SvPVx(ERRSV, n_a);
1358 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1366 if (cxix < cxstack_ix)
1369 POPBLOCK(cx,PL_curpm);
1370 if (CxTYPE(cx) != CXt_EVAL) {
1371 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1376 if (gimme == G_SCALAR)
1377 *++newsp = &PL_sv_undef;
1378 PL_stack_sp = newsp;
1382 if (optype == OP_REQUIRE) {
1383 char* msg = SvPVx(ERRSV, n_a);
1384 DIE("%s", *msg ? msg : "Compilation failed in require");
1386 return pop_return();
1390 message = SvPVx(ERRSV, n_a);
1391 PerlIO_printf(PerlIO_stderr(), "%s",message);
1392 PerlIO_flush(PerlIO_stderr());
1401 if (SvTRUE(left) != SvTRUE(right))
1413 RETURNOP(cLOGOP->op_other);
1422 RETURNOP(cLOGOP->op_other);
1428 register I32 cxix = dopoptosub(cxstack_ix);
1429 register PERL_CONTEXT *cx;
1430 register PERL_CONTEXT *ccstack = cxstack;
1431 PERL_SI *top_si = PL_curstackinfo;
1442 /* we may be in a higher stacklevel, so dig down deeper */
1443 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1444 top_si = top_si->si_prev;
1445 ccstack = top_si->si_cxstack;
1446 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1449 if (GIMME != G_ARRAY)
1453 if (PL_DBsub && cxix >= 0 &&
1454 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1458 cxix = dopoptosub_at(ccstack, cxix - 1);
1461 cx = &ccstack[cxix];
1462 if (CxTYPE(cx) == CXt_SUB) {
1463 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1464 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1465 field below is defined for any cx. */
1466 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1467 cx = &ccstack[dbcxix];
1470 if (GIMME != G_ARRAY) {
1471 hv = cx->blk_oldcop->cop_stash;
1473 PUSHs(&PL_sv_undef);
1476 sv_setpv(TARG, HvNAME(hv));
1482 hv = cx->blk_oldcop->cop_stash;
1484 PUSHs(&PL_sv_undef);
1486 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1487 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1488 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1491 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1493 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1494 PUSHs(sv_2mortal(sv));
1495 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1498 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1499 PUSHs(sv_2mortal(newSViv(0)));
1501 gimme = (I32)cx->blk_gimme;
1502 if (gimme == G_VOID)
1503 PUSHs(&PL_sv_undef);
1505 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1506 if (CxTYPE(cx) == CXt_EVAL) {
1507 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1508 PUSHs(cx->blk_eval.cur_text);
1511 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1512 /* Require, put the name. */
1513 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1517 else if (CxTYPE(cx) == CXt_SUB &&
1518 cx->blk_sub.hasargs &&
1519 PL_curcop->cop_stash == PL_debstash)
1521 AV *ary = cx->blk_sub.argarray;
1522 int off = AvARRAY(ary) - AvALLOC(ary);
1526 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1529 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1532 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1533 av_extend(PL_dbargs, AvFILLp(ary) + off);
1534 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1535 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1541 sortcv(SV *a, SV *b)
1544 I32 oldsaveix = PL_savestack_ix;
1545 I32 oldscopeix = PL_scopestack_ix;
1547 GvSV(PL_firstgv) = a;
1548 GvSV(PL_secondgv) = b;
1549 PL_stack_sp = PL_stack_base;
1552 if (PL_stack_sp != PL_stack_base + 1)
1553 croak("Sort subroutine didn't return single value");
1554 if (!SvNIOKp(*PL_stack_sp))
1555 croak("Sort subroutine didn't return a numeric value");
1556 result = SvIV(*PL_stack_sp);
1557 while (PL_scopestack_ix > oldscopeix) {
1560 leave_scope(oldsaveix);
1574 sv_reset(tmps, PL_curcop->cop_stash);
1586 PL_curcop = (COP*)PL_op;
1587 TAINT_NOT; /* Each statement is presumed innocent */
1588 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1591 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1595 register PERL_CONTEXT *cx;
1596 I32 gimme = G_ARRAY;
1603 DIE("No DB::DB routine defined");
1605 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1617 push_return(PL_op->op_next);
1618 PUSHBLOCK(cx, CXt_SUB, SP);
1621 (void)SvREFCNT_inc(cv);
1622 SAVESPTR(PL_curpad);
1623 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1624 RETURNOP(CvSTART(cv));
1638 register PERL_CONTEXT *cx;
1639 I32 gimme = GIMME_V;
1646 if (PL_op->op_flags & OPf_SPECIAL) {
1648 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1649 SAVEGENERICSV(*svp);
1653 #endif /* USE_THREADS */
1654 if (PL_op->op_targ) {
1655 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1659 svp = &GvSV((GV*)POPs); /* symbol table variable */
1660 SAVEGENERICSV(*svp);
1666 PUSHBLOCK(cx, CXt_LOOP, SP);
1667 PUSHLOOP(cx, svp, MARK);
1668 if (PL_op->op_flags & OPf_STACKED) {
1669 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1670 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1672 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1673 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1674 if (SvNV(sv) < IV_MIN ||
1675 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1676 croak("Range iterator outside integer range");
1677 cx->blk_loop.iterix = SvIV(sv);
1678 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1681 cx->blk_loop.iterlval = newSVsv(sv);
1685 cx->blk_loop.iterary = PL_curstack;
1686 AvFILLp(PL_curstack) = SP - PL_stack_base;
1687 cx->blk_loop.iterix = MARK - PL_stack_base;
1696 register PERL_CONTEXT *cx;
1697 I32 gimme = GIMME_V;
1703 PUSHBLOCK(cx, CXt_LOOP, SP);
1704 PUSHLOOP(cx, 0, SP);
1712 register PERL_CONTEXT *cx;
1713 struct block_loop cxloop;
1721 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1724 if (gimme == G_VOID)
1726 else if (gimme == G_SCALAR) {
1728 *++newsp = sv_mortalcopy(*SP);
1730 *++newsp = &PL_sv_undef;
1734 *++newsp = sv_mortalcopy(*++mark);
1735 TAINT_NOT; /* Each item is independent */
1741 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1742 PL_curpm = newpm; /* ... and pop $1 et al */
1754 register PERL_CONTEXT *cx;
1755 struct block_sub cxsub;
1756 bool popsub2 = FALSE;
1762 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1763 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1764 if (cxstack_ix > PL_sortcxix)
1765 dounwind(PL_sortcxix);
1766 AvARRAY(PL_curstack)[1] = *SP;
1767 PL_stack_sp = PL_stack_base + 1;
1772 cxix = dopoptosub(cxstack_ix);
1774 DIE("Can't return outside a subroutine");
1775 if (cxix < cxstack_ix)
1779 switch (CxTYPE(cx)) {
1781 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1786 if (optype == OP_REQUIRE &&
1787 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1789 /* Unassume the success we assumed earlier. */
1790 char *name = cx->blk_eval.old_name;
1791 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1792 DIE("%s did not return a true value", name);
1796 DIE("panic: return");
1800 if (gimme == G_SCALAR) {
1803 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1805 *++newsp = SvREFCNT_inc(*SP);
1810 *++newsp = sv_mortalcopy(*SP);
1813 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1815 *++newsp = sv_mortalcopy(*SP);
1817 *++newsp = &PL_sv_undef;
1819 else if (gimme == G_ARRAY) {
1820 while (++MARK <= SP) {
1821 *++newsp = (popsub2 && SvTEMP(*MARK))
1822 ? *MARK : sv_mortalcopy(*MARK);
1823 TAINT_NOT; /* Each item is independent */
1826 PL_stack_sp = newsp;
1828 /* Stack values are safe: */
1830 POPSUB2(); /* release CV and @_ ... */
1832 PL_curpm = newpm; /* ... and pop $1 et al */
1835 return pop_return();
1842 register PERL_CONTEXT *cx;
1843 struct block_loop cxloop;
1844 struct block_sub cxsub;
1851 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1853 if (PL_op->op_flags & OPf_SPECIAL) {
1854 cxix = dopoptoloop(cxstack_ix);
1856 DIE("Can't \"last\" outside a block");
1859 cxix = dopoptolabel(cPVOP->op_pv);
1861 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1863 if (cxix < cxstack_ix)
1867 switch (CxTYPE(cx)) {
1869 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1871 nextop = cxloop.last_op->op_next;
1874 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1876 nextop = pop_return();
1880 nextop = pop_return();
1887 if (gimme == G_SCALAR) {
1889 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1890 ? *SP : sv_mortalcopy(*SP);
1892 *++newsp = &PL_sv_undef;
1894 else if (gimme == G_ARRAY) {
1895 while (++MARK <= SP) {
1896 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1897 ? *MARK : sv_mortalcopy(*MARK);
1898 TAINT_NOT; /* Each item is independent */
1904 /* Stack values are safe: */
1907 POPLOOP2(); /* release loop vars ... */
1911 POPSUB2(); /* release CV and @_ ... */
1914 PL_curpm = newpm; /* ... and pop $1 et al */
1923 register PERL_CONTEXT *cx;
1926 if (PL_op->op_flags & OPf_SPECIAL) {
1927 cxix = dopoptoloop(cxstack_ix);
1929 DIE("Can't \"next\" outside a block");
1932 cxix = dopoptolabel(cPVOP->op_pv);
1934 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1936 if (cxix < cxstack_ix)
1940 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1941 LEAVE_SCOPE(oldsave);
1942 return cx->blk_loop.next_op;
1948 register PERL_CONTEXT *cx;
1951 if (PL_op->op_flags & OPf_SPECIAL) {
1952 cxix = dopoptoloop(cxstack_ix);
1954 DIE("Can't \"redo\" outside a block");
1957 cxix = dopoptolabel(cPVOP->op_pv);
1959 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1961 if (cxix < cxstack_ix)
1965 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1966 LEAVE_SCOPE(oldsave);
1967 return cx->blk_loop.redo_op;
1971 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1975 static char too_deep[] = "Target of goto is too deeply nested";
1979 if (o->op_type == OP_LEAVE ||
1980 o->op_type == OP_SCOPE ||
1981 o->op_type == OP_LEAVELOOP ||
1982 o->op_type == OP_LEAVETRY)
1984 *ops++ = cUNOPo->op_first;
1989 if (o->op_flags & OPf_KIDS) {
1991 /* First try all the kids at this level, since that's likeliest. */
1992 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1993 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1994 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1997 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1998 if (kid == PL_lastgotoprobe)
2000 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2002 (ops[-1]->op_type != OP_NEXTSTATE &&
2003 ops[-1]->op_type != OP_DBSTATE)))
2005 if (o = dofindlabel(kid, label, ops, oplimit))
2015 return pp_goto(ARGS);
2024 register PERL_CONTEXT *cx;
2025 #define GOTO_DEPTH 64
2026 OP *enterops[GOTO_DEPTH];
2028 int do_dump = (PL_op->op_type == OP_DUMP);
2029 static char must_have_label[] = "goto must have label";
2032 if (PL_op->op_flags & OPf_STACKED) {
2036 /* This egregious kludge implements goto &subroutine */
2037 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2039 register PERL_CONTEXT *cx;
2040 CV* cv = (CV*)SvRV(sv);
2044 int arg_was_real = 0;
2047 if (!CvROOT(cv) && !CvXSUB(cv)) {
2052 /* autoloaded stub? */
2053 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2055 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2056 GvNAMELEN(gv), FALSE);
2057 if (autogv && (cv = GvCV(autogv)))
2059 tmpstr = sv_newmortal();
2060 gv_efullname3(tmpstr, gv, Nullch);
2061 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2063 DIE("Goto undefined subroutine");
2066 /* First do some returnish stuff. */
2067 cxix = dopoptosub(cxstack_ix);
2069 DIE("Can't goto subroutine outside a subroutine");
2070 if (cxix < cxstack_ix)
2073 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2074 DIE("Can't goto subroutine from an eval-string");
2076 if (CxTYPE(cx) == CXt_SUB &&
2077 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2078 AV* av = cx->blk_sub.argarray;
2080 items = AvFILLp(av) + 1;
2082 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2083 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2084 PL_stack_sp += items;
2086 SvREFCNT_dec(GvAV(PL_defgv));
2087 GvAV(PL_defgv) = cx->blk_sub.savearray;
2088 #endif /* USE_THREADS */
2091 AvREAL_off(av); /* so av_clear() won't clobber elts */
2095 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2099 av = (AV*)PL_curpad[0];
2101 av = GvAV(PL_defgv);
2103 items = AvFILLp(av) + 1;
2105 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2106 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2107 PL_stack_sp += items;
2109 if (CxTYPE(cx) == CXt_SUB &&
2110 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2111 SvREFCNT_dec(cx->blk_sub.cv);
2112 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2113 LEAVE_SCOPE(oldsave);
2115 /* Now do some callish stuff. */
2118 if (CvOLDSTYLE(cv)) {
2119 I32 (*fp3)_((int,int,int));
2124 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2125 items = (*fp3)(CvXSUBANY(cv).any_i32,
2126 mark - PL_stack_base + 1,
2128 SP = PL_stack_base + items;
2134 PL_stack_sp--; /* There is no cv arg. */
2135 /* Push a mark for the start of arglist */
2137 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2138 /* Pop the current context like a decent sub should */
2139 POPBLOCK(cx, PL_curpm);
2140 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2143 return pop_return();
2146 AV* padlist = CvPADLIST(cv);
2147 SV** svp = AvARRAY(padlist);
2148 if (CxTYPE(cx) == CXt_EVAL) {
2149 PL_in_eval = cx->blk_eval.old_in_eval;
2150 PL_eval_root = cx->blk_eval.old_eval_root;
2151 cx->cx_type = CXt_SUB;
2152 cx->blk_sub.hasargs = 0;
2154 cx->blk_sub.cv = cv;
2155 cx->blk_sub.olddepth = CvDEPTH(cv);
2157 if (CvDEPTH(cv) < 2)
2158 (void)SvREFCNT_inc(cv);
2159 else { /* save temporaries on recursion? */
2160 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2161 sub_crush_depth(cv);
2162 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2163 AV *newpad = newAV();
2164 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2165 I32 ix = AvFILLp((AV*)svp[1]);
2166 svp = AvARRAY(svp[0]);
2167 for ( ;ix > 0; ix--) {
2168 if (svp[ix] != &PL_sv_undef) {
2169 char *name = SvPVX(svp[ix]);
2170 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2173 /* outer lexical or anon code */
2174 av_store(newpad, ix,
2175 SvREFCNT_inc(oldpad[ix]) );
2177 else { /* our own lexical */
2179 av_store(newpad, ix, sv = (SV*)newAV());
2180 else if (*name == '%')
2181 av_store(newpad, ix, sv = (SV*)newHV());
2183 av_store(newpad, ix, sv = NEWSV(0,0));
2188 av_store(newpad, ix, sv = NEWSV(0,0));
2192 if (cx->blk_sub.hasargs) {
2195 av_store(newpad, 0, (SV*)av);
2196 AvFLAGS(av) = AVf_REIFY;
2198 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2199 AvFILLp(padlist) = CvDEPTH(cv);
2200 svp = AvARRAY(padlist);
2204 if (!cx->blk_sub.hasargs) {
2205 AV* av = (AV*)PL_curpad[0];
2207 items = AvFILLp(av) + 1;
2209 /* Mark is at the end of the stack. */
2211 Copy(AvARRAY(av), SP + 1, items, SV*);
2216 #endif /* USE_THREADS */
2217 SAVESPTR(PL_curpad);
2218 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2220 if (cx->blk_sub.hasargs)
2221 #endif /* USE_THREADS */
2223 AV* av = (AV*)PL_curpad[0];
2227 cx->blk_sub.savearray = GvAV(PL_defgv);
2228 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2229 #endif /* USE_THREADS */
2230 cx->blk_sub.argarray = av;
2233 if (items >= AvMAX(av) + 1) {
2235 if (AvARRAY(av) != ary) {
2236 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2237 SvPVX(av) = (char*)ary;
2239 if (items >= AvMAX(av) + 1) {
2240 AvMAX(av) = items - 1;
2241 Renew(ary,items+1,SV*);
2243 SvPVX(av) = (char*)ary;
2246 Copy(mark,AvARRAY(av),items,SV*);
2247 AvFILLp(av) = items - 1;
2248 /* preserve @_ nature */
2259 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2261 * We do not care about using sv to call CV;
2262 * it's for informational purposes only.
2264 SV *sv = GvSV(PL_DBsub);
2267 if (PERLDB_SUB_NN) {
2268 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2271 gv_efullname3(sv, CvGV(cv), Nullch);
2274 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2275 PUSHMARK( PL_stack_sp );
2276 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2280 RETURNOP(CvSTART(cv));
2284 label = SvPV(sv,n_a);
2285 if (!(do_dump || *label))
2286 DIE(must_have_label);
2289 else if (PL_op->op_flags & OPf_SPECIAL) {
2291 DIE(must_have_label);
2294 label = cPVOP->op_pv;
2296 if (label && *label) {
2301 PL_lastgotoprobe = 0;
2303 for (ix = cxstack_ix; ix >= 0; ix--) {
2305 switch (CxTYPE(cx)) {
2307 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2310 gotoprobe = cx->blk_oldcop->op_sibling;
2316 gotoprobe = cx->blk_oldcop->op_sibling;
2318 gotoprobe = PL_main_root;
2321 if (CvDEPTH(cx->blk_sub.cv)) {
2322 gotoprobe = CvROOT(cx->blk_sub.cv);
2327 DIE("Can't \"goto\" outside a block");
2331 gotoprobe = PL_main_root;
2334 retop = dofindlabel(gotoprobe, label,
2335 enterops, enterops + GOTO_DEPTH);
2338 PL_lastgotoprobe = gotoprobe;
2341 DIE("Can't find label %s", label);
2343 /* pop unwanted frames */
2345 if (ix < cxstack_ix) {
2352 oldsave = PL_scopestack[PL_scopestack_ix];
2353 LEAVE_SCOPE(oldsave);
2356 /* push wanted frames */
2358 if (*enterops && enterops[1]) {
2360 for (ix = 1; enterops[ix]; ix++) {
2361 PL_op = enterops[ix];
2362 /* Eventually we may want to stack the needed arguments
2363 * for each op. For now, we punt on the hard ones. */
2364 if (PL_op->op_type == OP_ENTERITER)
2365 DIE("Can't \"goto\" into the middle of a foreach loop",
2367 (CALLOP->op_ppaddr)(ARGS);
2375 if (!retop) retop = PL_main_start;
2377 PL_restartop = retop;
2378 PL_do_undump = TRUE;
2382 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2383 PL_do_undump = FALSE;
2399 if (anum == 1 && VMSISH_EXIT)
2404 PUSHs(&PL_sv_undef);
2412 double value = SvNVx(GvSV(cCOP->cop_gv));
2413 register I32 match = I_32(value);
2416 if (((double)match) > value)
2417 --match; /* was fractional--truncate other way */
2419 match -= cCOP->uop.scop.scop_offset;
2422 else if (match > cCOP->uop.scop.scop_max)
2423 match = cCOP->uop.scop.scop_max;
2424 PL_op = cCOP->uop.scop.scop_next[match];
2434 PL_op = PL_op->op_next; /* can't assume anything */
2437 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2438 match -= cCOP->uop.scop.scop_offset;
2441 else if (match > cCOP->uop.scop.scop_max)
2442 match = cCOP->uop.scop.scop_max;
2443 PL_op = cCOP->uop.scop.scop_next[match];
2452 save_lines(AV *array, SV *sv)
2454 register char *s = SvPVX(sv);
2455 register char *send = SvPVX(sv) + SvCUR(sv);
2457 register I32 line = 1;
2459 while (s && s < send) {
2460 SV *tmpstr = NEWSV(85,0);
2462 sv_upgrade(tmpstr, SVt_PVMG);
2463 t = strchr(s, '\n');
2469 sv_setpvn(tmpstr, s, t - s);
2470 av_store(array, line++, tmpstr);
2485 assert(CATCH_GET == TRUE);
2486 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2490 default: /* topmost level handles it */
2499 PL_op = PL_restartop;
2512 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2513 /* sv Text to convert to OP tree. */
2514 /* startop op_free() this to undo. */
2515 /* code Short string id of the caller. */
2517 dSP; /* Make POPBLOCK work. */
2520 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2523 OP *oop = PL_op, *rop;
2524 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2530 /* switch to eval mode */
2532 if (PL_curcop == &PL_compiling) {
2533 SAVESPTR(PL_compiling.cop_stash);
2534 PL_compiling.cop_stash = PL_curstash;
2536 SAVESPTR(PL_compiling.cop_filegv);
2537 SAVEI16(PL_compiling.cop_line);
2538 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2539 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2540 PL_compiling.cop_line = 1;
2541 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2542 deleting the eval's FILEGV from the stash before gv_check() runs
2543 (i.e. before run-time proper). To work around the coredump that
2544 ensues, we always turn GvMULTI_on for any globals that were
2545 introduced within evals. See force_ident(). GSAR 96-10-12 */
2546 safestr = savepv(tmpbuf);
2547 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2549 #ifdef OP_IN_REGISTER
2557 PL_op->op_type = OP_ENTEREVAL;
2558 PL_op->op_flags = 0; /* Avoid uninit warning. */
2559 PUSHBLOCK(cx, CXt_EVAL, SP);
2560 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2561 rop = doeval(G_SCALAR, startop);
2562 POPBLOCK(cx,PL_curpm);
2565 (*startop)->op_type = OP_NULL;
2566 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2568 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2570 if (PL_curcop == &PL_compiling)
2571 PL_compiling.op_private = PL_hints;
2572 #ifdef OP_IN_REGISTER
2578 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2580 doeval(int gimme, OP** startop)
2593 /* set up a scratch pad */
2596 SAVESPTR(PL_curpad);
2597 SAVESPTR(PL_comppad);
2598 SAVESPTR(PL_comppad_name);
2599 SAVEI32(PL_comppad_name_fill);
2600 SAVEI32(PL_min_intro_pending);
2601 SAVEI32(PL_max_intro_pending);
2604 for (i = cxstack_ix - 1; i >= 0; i--) {
2605 PERL_CONTEXT *cx = &cxstack[i];
2606 if (CxTYPE(cx) == CXt_EVAL)
2608 else if (CxTYPE(cx) == CXt_SUB) {
2609 caller = cx->blk_sub.cv;
2614 SAVESPTR(PL_compcv);
2615 PL_compcv = (CV*)NEWSV(1104,0);
2616 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2617 CvUNIQUE_on(PL_compcv);
2619 CvOWNER(PL_compcv) = 0;
2620 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2621 MUTEX_INIT(CvMUTEXP(PL_compcv));
2622 #endif /* USE_THREADS */
2624 PL_comppad = newAV();
2625 av_push(PL_comppad, Nullsv);
2626 PL_curpad = AvARRAY(PL_comppad);
2627 PL_comppad_name = newAV();
2628 PL_comppad_name_fill = 0;
2629 PL_min_intro_pending = 0;
2632 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2633 PL_curpad[0] = (SV*)newAV();
2634 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2635 #endif /* USE_THREADS */
2637 comppadlist = newAV();
2638 AvREAL_off(comppadlist);
2639 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2640 av_store(comppadlist, 1, (SV*)PL_comppad);
2641 CvPADLIST(PL_compcv) = comppadlist;
2643 if (!saveop || saveop->op_type != OP_REQUIRE)
2644 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2646 SAVEFREESV(PL_compcv);
2648 /* make sure we compile in the right package */
2650 newstash = PL_curcop->cop_stash;
2651 if (PL_curstash != newstash) {
2652 SAVESPTR(PL_curstash);
2653 PL_curstash = newstash;
2655 SAVESPTR(PL_beginav);
2656 PL_beginav = newAV();
2657 SAVEFREESV(PL_beginav);
2659 /* try to compile it */
2661 PL_eval_root = Nullop;
2663 PL_curcop = &PL_compiling;
2664 PL_curcop->cop_arybase = 0;
2665 SvREFCNT_dec(PL_rs);
2666 PL_rs = newSVpv("\n", 1);
2667 if (saveop && saveop->op_flags & OPf_SPECIAL)
2671 if (yyparse() || PL_error_count || !PL_eval_root) {
2675 I32 optype = 0; /* Might be reset by POPEVAL. */
2680 op_free(PL_eval_root);
2681 PL_eval_root = Nullop;
2683 SP = PL_stack_base + POPMARK; /* pop original mark */
2685 POPBLOCK(cx,PL_curpm);
2691 if (optype == OP_REQUIRE) {
2692 char* msg = SvPVx(ERRSV, n_a);
2693 DIE("%s", *msg ? msg : "Compilation failed in require");
2694 } else if (startop) {
2695 char* msg = SvPVx(ERRSV, n_a);
2697 POPBLOCK(cx,PL_curpm);
2699 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2701 SvREFCNT_dec(PL_rs);
2702 PL_rs = SvREFCNT_inc(PL_nrs);
2704 MUTEX_LOCK(&PL_eval_mutex);
2706 COND_SIGNAL(&PL_eval_cond);
2707 MUTEX_UNLOCK(&PL_eval_mutex);
2708 #endif /* USE_THREADS */
2711 SvREFCNT_dec(PL_rs);
2712 PL_rs = SvREFCNT_inc(PL_nrs);
2713 PL_compiling.cop_line = 0;
2715 *startop = PL_eval_root;
2716 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2717 CvOUTSIDE(PL_compcv) = Nullcv;
2719 SAVEFREEOP(PL_eval_root);
2721 scalarvoid(PL_eval_root);
2722 else if (gimme & G_ARRAY)
2725 scalar(PL_eval_root);
2727 DEBUG_x(dump_eval());
2729 /* Register with debugger: */
2730 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2731 CV *cv = perl_get_cv("DB::postponed", FALSE);
2735 XPUSHs((SV*)PL_compiling.cop_filegv);
2737 perl_call_sv((SV*)cv, G_DISCARD);
2741 /* compiled okay, so do it */
2743 CvDEPTH(PL_compcv) = 1;
2744 SP = PL_stack_base + POPMARK; /* pop original mark */
2745 PL_op = saveop; /* The caller may need it. */
2747 MUTEX_LOCK(&PL_eval_mutex);
2749 COND_SIGNAL(&PL_eval_cond);
2750 MUTEX_UNLOCK(&PL_eval_mutex);
2751 #endif /* USE_THREADS */
2753 RETURNOP(PL_eval_start);
2759 register PERL_CONTEXT *cx;
2764 SV *namesv = Nullsv;
2766 I32 gimme = G_SCALAR;
2767 PerlIO *tryrsfp = 0;
2771 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2772 SET_NUMERIC_STANDARD();
2773 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2774 DIE("Perl %s required--this is only version %s, stopped",
2775 SvPV(sv,n_a),PL_patchlevel);
2778 name = SvPV(sv, len);
2779 if (!(name && len > 0 && *name))
2780 DIE("Null filename used");
2781 TAINT_PROPER("require");
2782 if (PL_op->op_type == OP_REQUIRE &&
2783 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2784 *svp != &PL_sv_undef)
2787 /* prepare to compile file */
2792 (name[1] == '.' && name[2] == '/')))
2794 || (name[0] && name[1] == ':')
2797 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2800 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2801 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2806 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2809 AV *ar = GvAVn(PL_incgv);
2813 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2816 namesv = NEWSV(806, 0);
2817 for (i = 0; i <= AvFILL(ar); i++) {
2818 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2821 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2823 sv_setpv(namesv, unixdir);
2824 sv_catpv(namesv, unixname);
2826 sv_setpvf(namesv, "%s/%s", dir, name);
2828 TAINT_PROPER("require");
2829 tryname = SvPVX(namesv);
2830 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2832 if (tryname[0] == '.' && tryname[1] == '/')
2839 SAVESPTR(PL_compiling.cop_filegv);
2840 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2841 SvREFCNT_dec(namesv);
2843 if (PL_op->op_type == OP_REQUIRE) {
2844 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2845 SV *dirmsgsv = NEWSV(0, 0);
2846 AV *ar = GvAVn(PL_incgv);
2848 if (instr(SvPVX(msg), ".h "))
2849 sv_catpv(msg, " (change .h to .ph maybe?)");
2850 if (instr(SvPVX(msg), ".ph "))
2851 sv_catpv(msg, " (did you run h2ph?)");
2852 sv_catpv(msg, " (@INC contains:");
2853 for (i = 0; i <= AvFILL(ar); i++) {
2854 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2855 sv_setpvf(dirmsgsv, " %s", dir);
2856 sv_catsv(msg, dirmsgsv);
2858 sv_catpvn(msg, ")", 1);
2859 SvREFCNT_dec(dirmsgsv);
2866 SETERRNO(0, SS$_NORMAL);
2868 /* Assume success here to prevent recursive requirement. */
2869 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2870 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2874 lex_start(sv_2mortal(newSVpv("",0)));
2875 SAVEGENERICSV(PL_rsfp_filters);
2876 PL_rsfp_filters = Nullav;
2879 name = savepv(name);
2883 SAVEPPTR(PL_compiling.cop_warnings);
2884 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2887 /* switch to eval mode */
2889 push_return(PL_op->op_next);
2890 PUSHBLOCK(cx, CXt_EVAL, SP);
2891 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2893 SAVEI16(PL_compiling.cop_line);
2894 PL_compiling.cop_line = 0;
2898 MUTEX_LOCK(&PL_eval_mutex);
2899 if (PL_eval_owner && PL_eval_owner != thr)
2900 while (PL_eval_owner)
2901 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2902 PL_eval_owner = thr;
2903 MUTEX_UNLOCK(&PL_eval_mutex);
2904 #endif /* USE_THREADS */
2905 return DOCATCH(doeval(G_SCALAR, NULL));
2910 return pp_require(ARGS);
2916 register PERL_CONTEXT *cx;
2918 I32 gimme = GIMME_V, was = PL_sub_generation;
2919 char tmpbuf[TYPE_DIGITS(long) + 12];
2924 if (!SvPV(sv,len) || !len)
2926 TAINT_PROPER("eval");
2932 /* switch to eval mode */
2934 SAVESPTR(PL_compiling.cop_filegv);
2935 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2936 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2937 PL_compiling.cop_line = 1;
2938 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2939 deleting the eval's FILEGV from the stash before gv_check() runs
2940 (i.e. before run-time proper). To work around the coredump that
2941 ensues, we always turn GvMULTI_on for any globals that were
2942 introduced within evals. See force_ident(). GSAR 96-10-12 */
2943 safestr = savepv(tmpbuf);
2944 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2946 PL_hints = PL_op->op_targ;
2947 SAVEPPTR(PL_compiling.cop_warnings);
2948 if (PL_compiling.cop_warnings != WARN_ALL
2949 && PL_compiling.cop_warnings != WARN_NONE){
2950 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2951 SAVEFREESV(PL_compiling.cop_warnings) ;
2954 push_return(PL_op->op_next);
2955 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2956 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2958 /* prepare to compile string */
2960 if (PERLDB_LINE && PL_curstash != PL_debstash)
2961 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2964 MUTEX_LOCK(&PL_eval_mutex);
2965 if (PL_eval_owner && PL_eval_owner != thr)
2966 while (PL_eval_owner)
2967 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2968 PL_eval_owner = thr;
2969 MUTEX_UNLOCK(&PL_eval_mutex);
2970 #endif /* USE_THREADS */
2971 ret = doeval(gimme, NULL);
2972 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2973 && ret != PL_op->op_next) { /* Successive compilation. */
2974 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2976 return DOCATCH(ret);
2986 register PERL_CONTEXT *cx;
2988 U8 save_flags = PL_op -> op_flags;
2993 retop = pop_return();
2996 if (gimme == G_VOID)
2998 else if (gimme == G_SCALAR) {
3001 if (SvFLAGS(TOPs) & SVs_TEMP)
3004 *MARK = sv_mortalcopy(TOPs);
3008 *MARK = &PL_sv_undef;
3012 /* in case LEAVE wipes old return values */
3013 for (mark = newsp + 1; mark <= SP; mark++) {
3014 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3015 *mark = sv_mortalcopy(*mark);
3016 TAINT_NOT; /* Each item is independent */
3020 PL_curpm = newpm; /* Don't pop $1 et al till now */
3023 * Closures mentioned at top level of eval cannot be referenced
3024 * again, and their presence indirectly causes a memory leak.
3025 * (Note that the fact that compcv and friends are still set here
3026 * is, AFAIK, an accident.) --Chip
3028 if (AvFILLp(PL_comppad_name) >= 0) {
3029 SV **svp = AvARRAY(PL_comppad_name);
3031 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3033 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3035 svp[ix] = &PL_sv_undef;
3039 SvREFCNT_dec(CvOUTSIDE(sv));
3040 CvOUTSIDE(sv) = Nullcv;
3053 assert(CvDEPTH(PL_compcv) == 1);
3055 CvDEPTH(PL_compcv) = 0;
3058 if (optype == OP_REQUIRE &&
3059 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3061 /* Unassume the success we assumed earlier. */
3062 char *name = cx->blk_eval.old_name;
3063 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3064 retop = die("%s did not return a true value", name);
3065 /* die_where() did LEAVE, or we won't be here */
3069 if (!(save_flags & OPf_SPECIAL))
3079 register PERL_CONTEXT *cx;
3080 I32 gimme = GIMME_V;
3085 push_return(cLOGOP->op_other->op_next);
3086 PUSHBLOCK(cx, CXt_EVAL, SP);
3088 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3093 return DOCATCH(PL_op->op_next);
3103 register PERL_CONTEXT *cx;
3111 if (gimme == G_VOID)
3113 else if (gimme == G_SCALAR) {
3116 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3119 *MARK = sv_mortalcopy(TOPs);
3123 *MARK = &PL_sv_undef;
3128 /* in case LEAVE wipes old return values */
3129 for (mark = newsp + 1; mark <= SP; mark++) {
3130 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3131 *mark = sv_mortalcopy(*mark);
3132 TAINT_NOT; /* Each item is independent */
3136 PL_curpm = newpm; /* Don't pop $1 et al till now */
3147 register char *s = SvPV_force(sv, len);
3148 register char *send = s + len;
3149 register char *base;
3150 register I32 skipspaces = 0;
3153 bool postspace = FALSE;
3161 croak("Null picture in formline");
3163 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3168 *fpc++ = FF_LINEMARK;
3169 noblank = repeat = FALSE;
3187 case ' ': case '\t':
3198 *fpc++ = FF_LITERAL;
3206 *fpc++ = skipspaces;
3210 *fpc++ = FF_NEWLINE;
3214 arg = fpc - linepc + 1;
3221 *fpc++ = FF_LINEMARK;
3222 noblank = repeat = FALSE;
3231 ischop = s[-1] == '^';
3237 arg = (s - base) - 1;
3239 *fpc++ = FF_LITERAL;
3248 *fpc++ = FF_LINEGLOB;
3250 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3251 arg = ischop ? 512 : 0;
3261 arg |= 256 + (s - f);
3263 *fpc++ = s - base; /* fieldsize for FETCH */
3264 *fpc++ = FF_DECIMAL;
3269 bool ismore = FALSE;
3272 while (*++s == '>') ;
3273 prespace = FF_SPACE;
3275 else if (*s == '|') {
3276 while (*++s == '|') ;
3277 prespace = FF_HALFSPACE;
3282 while (*++s == '<') ;
3285 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3289 *fpc++ = s - base; /* fieldsize for FETCH */
3291 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3309 { /* need to jump to the next word */
3311 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3312 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3313 s = SvPVX(sv) + SvCUR(sv) + z;
3315 Copy(fops, s, arg, U16);
3317 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3322 * The rest of this file was derived from source code contributed
3325 * NOTE: this code was derived from Tom Horsley's qsort replacement
3326 * and should not be confused with the original code.
3329 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3331 Permission granted to distribute under the same terms as perl which are
3334 This program is free software; you can redistribute it and/or modify
3335 it under the terms of either:
3337 a) the GNU General Public License as published by the Free
3338 Software Foundation; either version 1, or (at your option) any
3341 b) the "Artistic License" which comes with this Kit.
3343 Details on the perl license can be found in the perl source code which
3344 may be located via the www.perl.com web page.
3346 This is the most wonderfulest possible qsort I can come up with (and
3347 still be mostly portable) My (limited) tests indicate it consistently
3348 does about 20% fewer calls to compare than does the qsort in the Visual
3349 C++ library, other vendors may vary.
3351 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3352 others I invented myself (or more likely re-invented since they seemed
3353 pretty obvious once I watched the algorithm operate for a while).
3355 Most of this code was written while watching the Marlins sweep the Giants
3356 in the 1997 National League Playoffs - no Braves fans allowed to use this
3357 code (just kidding :-).
3359 I realize that if I wanted to be true to the perl tradition, the only
3360 comment in this file would be something like:
3362 ...they shuffled back towards the rear of the line. 'No, not at the
3363 rear!' the slave-driver shouted. 'Three files up. And stay there...
3365 However, I really needed to violate that tradition just so I could keep
3366 track of what happens myself, not to mention some poor fool trying to
3367 understand this years from now :-).
3370 /* ********************************************************** Configuration */
3372 #ifndef QSORT_ORDER_GUESS
3373 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3376 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3377 future processing - a good max upper bound is log base 2 of memory size
3378 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3379 safely be smaller than that since the program is taking up some space and
3380 most operating systems only let you grab some subset of contiguous
3381 memory (not to mention that you are normally sorting data larger than
3382 1 byte element size :-).
3384 #ifndef QSORT_MAX_STACK
3385 #define QSORT_MAX_STACK 32
3388 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3389 Anything bigger and we use qsort. If you make this too small, the qsort
3390 will probably break (or become less efficient), because it doesn't expect
3391 the middle element of a partition to be the same as the right or left -
3392 you have been warned).
3394 #ifndef QSORT_BREAK_EVEN
3395 #define QSORT_BREAK_EVEN 6
3398 /* ************************************************************* Data Types */
3400 /* hold left and right index values of a partition waiting to be sorted (the
3401 partition includes both left and right - right is NOT one past the end or
3402 anything like that).
3404 struct partition_stack_entry {
3407 #ifdef QSORT_ORDER_GUESS
3408 int qsort_break_even;
3412 /* ******************************************************* Shorthand Macros */
3414 /* Note that these macros will be used from inside the qsort function where
3415 we happen to know that the variable 'elt_size' contains the size of an
3416 array element and the variable 'temp' points to enough space to hold a
3417 temp element and the variable 'array' points to the array being sorted
3418 and 'compare' is the pointer to the compare routine.
3420 Also note that there are very many highly architecture specific ways
3421 these might be sped up, but this is simply the most generally portable
3422 code I could think of.
3425 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3428 #define qsort_cmp(elt1, elt2) \
3429 ((this->*compare)(array[elt1], array[elt2]))
3431 #define qsort_cmp(elt1, elt2) \
3432 ((*compare)(array[elt1], array[elt2]))
3435 #ifdef QSORT_ORDER_GUESS
3436 #define QSORT_NOTICE_SWAP swapped++;
3438 #define QSORT_NOTICE_SWAP
3441 /* swaps contents of array elements elt1, elt2.
3443 #define qsort_swap(elt1, elt2) \
3446 temp = array[elt1]; \
3447 array[elt1] = array[elt2]; \
3448 array[elt2] = temp; \
3451 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3452 elt3 and elt3 gets elt1.
3454 #define qsort_rotate(elt1, elt2, elt3) \
3457 temp = array[elt1]; \
3458 array[elt1] = array[elt2]; \
3459 array[elt2] = array[elt3]; \
3460 array[elt3] = temp; \
3463 /* ************************************************************ Debug stuff */
3470 return; /* good place to set a breakpoint */
3473 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3476 doqsort_all_asserts(
3480 int (*compare)(const void * elt1, const void * elt2),
3481 int pc_left, int pc_right, int u_left, int u_right)
3485 qsort_assert(pc_left <= pc_right);
3486 qsort_assert(u_right < pc_left);
3487 qsort_assert(pc_right < u_left);
3488 for (i = u_right + 1; i < pc_left; ++i) {
3489 qsort_assert(qsort_cmp(i, pc_left) < 0);
3491 for (i = pc_left; i < pc_right; ++i) {
3492 qsort_assert(qsort_cmp(i, pc_right) == 0);
3494 for (i = pc_right + 1; i < u_left; ++i) {
3495 qsort_assert(qsort_cmp(pc_right, i) < 0);
3499 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3500 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3501 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3505 #define qsort_assert(t) ((void)0)
3507 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3511 /* ****************************************************************** qsort */
3515 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3520 I32 (*compare)(SV *a, SV *b))
3525 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3526 int next_stack_entry = 0;
3530 #ifdef QSORT_ORDER_GUESS
3531 int qsort_break_even;
3535 /* Make sure we actually have work to do.
3537 if (num_elts <= 1) {
3541 /* Setup the initial partition definition and fall into the sorting loop
3544 part_right = (int)(num_elts - 1);
3545 #ifdef QSORT_ORDER_GUESS
3546 qsort_break_even = QSORT_BREAK_EVEN;
3548 #define qsort_break_even QSORT_BREAK_EVEN
3551 if ((part_right - part_left) >= qsort_break_even) {
3552 /* OK, this is gonna get hairy, so lets try to document all the
3553 concepts and abbreviations and variables and what they keep
3556 pc: pivot chunk - the set of array elements we accumulate in the
3557 middle of the partition, all equal in value to the original
3558 pivot element selected. The pc is defined by:
3560 pc_left - the leftmost array index of the pc
3561 pc_right - the rightmost array index of the pc
3563 we start with pc_left == pc_right and only one element
3564 in the pivot chunk (but it can grow during the scan).
3566 u: uncompared elements - the set of elements in the partition
3567 we have not yet compared to the pivot value. There are two
3568 uncompared sets during the scan - one to the left of the pc
3569 and one to the right.
3571 u_right - the rightmost index of the left side's uncompared set
3572 u_left - the leftmost index of the right side's uncompared set
3574 The leftmost index of the left sides's uncompared set
3575 doesn't need its own variable because it is always defined
3576 by the leftmost edge of the whole partition (part_left). The
3577 same goes for the rightmost edge of the right partition
3580 We know there are no uncompared elements on the left once we
3581 get u_right < part_left and no uncompared elements on the
3582 right once u_left > part_right. When both these conditions
3583 are met, we have completed the scan of the partition.
3585 Any elements which are between the pivot chunk and the
3586 uncompared elements should be less than the pivot value on
3587 the left side and greater than the pivot value on the right
3588 side (in fact, the goal of the whole algorithm is to arrange
3589 for that to be true and make the groups of less-than and
3590 greater-then elements into new partitions to sort again).
3592 As you marvel at the complexity of the code and wonder why it
3593 has to be so confusing. Consider some of the things this level
3594 of confusion brings:
3596 Once I do a compare, I squeeze every ounce of juice out of it. I
3597 never do compare calls I don't have to do, and I certainly never
3600 I also never swap any elements unless I can prove there is a
3601 good reason. Many sort algorithms will swap a known value with
3602 an uncompared value just to get things in the right place (or
3603 avoid complexity :-), but that uncompared value, once it gets
3604 compared, may then have to be swapped again. A lot of the
3605 complexity of this code is due to the fact that it never swaps
3606 anything except compared values, and it only swaps them when the
3607 compare shows they are out of position.
3609 int pc_left, pc_right;
3610 int u_right, u_left;
3614 pc_left = ((part_left + part_right) / 2);
3616 u_right = pc_left - 1;
3617 u_left = pc_right + 1;
3619 /* Qsort works best when the pivot value is also the median value
3620 in the partition (unfortunately you can't find the median value
3621 without first sorting :-), so to give the algorithm a helping
3622 hand, we pick 3 elements and sort them and use the median value
3623 of that tiny set as the pivot value.
3625 Some versions of qsort like to use the left middle and right as
3626 the 3 elements to sort so they can insure the ends of the
3627 partition will contain values which will stop the scan in the
3628 compare loop, but when you have to call an arbitrarily complex
3629 routine to do a compare, its really better to just keep track of
3630 array index values to know when you hit the edge of the
3631 partition and avoid the extra compare. An even better reason to
3632 avoid using a compare call is the fact that you can drop off the
3633 edge of the array if someone foolishly provides you with an
3634 unstable compare function that doesn't always provide consistent
3637 So, since it is simpler for us to compare the three adjacent
3638 elements in the middle of the partition, those are the ones we
3639 pick here (conveniently pointed at by u_right, pc_left, and
3640 u_left). The values of the left, center, and right elements
3641 are refered to as l c and r in the following comments.
3644 #ifdef QSORT_ORDER_GUESS
3647 s = qsort_cmp(u_right, pc_left);
3650 s = qsort_cmp(pc_left, u_left);
3651 /* if l < c, c < r - already in order - nothing to do */
3653 /* l < c, c == r - already in order, pc grows */
3655 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3657 /* l < c, c > r - need to know more */
3658 s = qsort_cmp(u_right, u_left);
3660 /* l < c, c > r, l < r - swap c & r to get ordered */
3661 qsort_swap(pc_left, u_left);
3662 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3663 } else if (s == 0) {
3664 /* l < c, c > r, l == r - swap c&r, grow pc */
3665 qsort_swap(pc_left, u_left);
3667 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3669 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3670 qsort_rotate(pc_left, u_right, u_left);
3671 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3674 } else if (s == 0) {
3676 s = qsort_cmp(pc_left, u_left);
3678 /* l == c, c < r - already in order, grow pc */
3680 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3681 } else if (s == 0) {
3682 /* l == c, c == r - already in order, grow pc both ways */
3685 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3687 /* l == c, c > r - swap l & r, grow pc */
3688 qsort_swap(u_right, u_left);
3690 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3694 s = qsort_cmp(pc_left, u_left);
3696 /* l > c, c < r - need to know more */
3697 s = qsort_cmp(u_right, u_left);
3699 /* l > c, c < r, l < r - swap l & c to get ordered */
3700 qsort_swap(u_right, pc_left);
3701 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3702 } else if (s == 0) {
3703 /* l > c, c < r, l == r - swap l & c, grow pc */
3704 qsort_swap(u_right, pc_left);
3706 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3708 /* l > c, c < r, l > r - rotate lcr into crl to order */
3709 qsort_rotate(u_right, pc_left, u_left);
3710 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3712 } else if (s == 0) {
3713 /* l > c, c == r - swap ends, grow pc */
3714 qsort_swap(u_right, u_left);
3716 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3718 /* l > c, c > r - swap ends to get in order */
3719 qsort_swap(u_right, u_left);
3720 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3723 /* We now know the 3 middle elements have been compared and
3724 arranged in the desired order, so we can shrink the uncompared
3729 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3731 /* The above massive nested if was the simple part :-). We now have
3732 the middle 3 elements ordered and we need to scan through the
3733 uncompared sets on either side, swapping elements that are on
3734 the wrong side or simply shuffling equal elements around to get
3735 all equal elements into the pivot chunk.
3739 int still_work_on_left;
3740 int still_work_on_right;
3742 /* Scan the uncompared values on the left. If I find a value
3743 equal to the pivot value, move it over so it is adjacent to
3744 the pivot chunk and expand the pivot chunk. If I find a value
3745 less than the pivot value, then just leave it - its already
3746 on the correct side of the partition. If I find a greater
3747 value, then stop the scan.
3749 while (still_work_on_left = (u_right >= part_left)) {
3750 s = qsort_cmp(u_right, pc_left);
3753 } else if (s == 0) {
3755 if (pc_left != u_right) {
3756 qsort_swap(u_right, pc_left);
3762 qsort_assert(u_right < pc_left);
3763 qsort_assert(pc_left <= pc_right);
3764 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3765 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3768 /* Do a mirror image scan of uncompared values on the right
3770 while (still_work_on_right = (u_left <= part_right)) {
3771 s = qsort_cmp(pc_right, u_left);
3774 } else if (s == 0) {
3776 if (pc_right != u_left) {
3777 qsort_swap(pc_right, u_left);
3783 qsort_assert(u_left > pc_right);
3784 qsort_assert(pc_left <= pc_right);
3785 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3786 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3789 if (still_work_on_left) {
3790 /* I know I have a value on the left side which needs to be
3791 on the right side, but I need to know more to decide
3792 exactly the best thing to do with it.
3794 if (still_work_on_right) {
3795 /* I know I have values on both side which are out of
3796 position. This is a big win because I kill two birds
3797 with one swap (so to speak). I can advance the
3798 uncompared pointers on both sides after swapping both
3799 of them into the right place.
3801 qsort_swap(u_right, u_left);
3804 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3806 /* I have an out of position value on the left, but the
3807 right is fully scanned, so I "slide" the pivot chunk
3808 and any less-than values left one to make room for the
3809 greater value over on the right. If the out of position
3810 value is immediately adjacent to the pivot chunk (there
3811 are no less-than values), I can do that with a swap,
3812 otherwise, I have to rotate one of the less than values
3813 into the former position of the out of position value
3814 and the right end of the pivot chunk into the left end
3818 if (pc_left == u_right) {
3819 qsort_swap(u_right, pc_right);
3820 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3822 qsort_rotate(u_right, pc_left, pc_right);
3823 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3828 } else if (still_work_on_right) {
3829 /* Mirror image of complex case above: I have an out of
3830 position value on the right, but the left is fully
3831 scanned, so I need to shuffle things around to make room
3832 for the right value on the left.
3835 if (pc_right == u_left) {
3836 qsort_swap(u_left, pc_left);
3837 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3839 qsort_rotate(pc_right, pc_left, u_left);
3840 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3845 /* No more scanning required on either side of partition,
3846 break out of loop and figure out next set of partitions
3852 /* The elements in the pivot chunk are now in the right place. They
3853 will never move or be compared again. All I have to do is decide
3854 what to do with the stuff to the left and right of the pivot
3857 Notes on the QSORT_ORDER_GUESS ifdef code:
3859 1. If I just built these partitions without swapping any (or
3860 very many) elements, there is a chance that the elements are
3861 already ordered properly (being properly ordered will
3862 certainly result in no swapping, but the converse can't be
3865 2. A (properly written) insertion sort will run faster on
3866 already ordered data than qsort will.
3868 3. Perhaps there is some way to make a good guess about
3869 switching to an insertion sort earlier than partition size 6
3870 (for instance - we could save the partition size on the stack
3871 and increase the size each time we find we didn't swap, thus
3872 switching to insertion sort earlier for partitions with a
3873 history of not swapping).
3875 4. Naturally, if I just switch right away, it will make
3876 artificial benchmarks with pure ascending (or descending)
3877 data look really good, but is that a good reason in general?
3881 #ifdef QSORT_ORDER_GUESS
3883 #if QSORT_ORDER_GUESS == 1
3884 qsort_break_even = (part_right - part_left) + 1;
3886 #if QSORT_ORDER_GUESS == 2
3887 qsort_break_even *= 2;
3889 #if QSORT_ORDER_GUESS == 3
3890 int prev_break = qsort_break_even;
3891 qsort_break_even *= qsort_break_even;
3892 if (qsort_break_even < prev_break) {
3893 qsort_break_even = (part_right - part_left) + 1;
3897 qsort_break_even = QSORT_BREAK_EVEN;
3901 if (part_left < pc_left) {
3902 /* There are elements on the left which need more processing.
3903 Check the right as well before deciding what to do.
3905 if (pc_right < part_right) {
3906 /* We have two partitions to be sorted. Stack the biggest one
3907 and process the smallest one on the next iteration. This
3908 minimizes the stack height by insuring that any additional
3909 stack entries must come from the smallest partition which
3910 (because it is smallest) will have the fewest
3911 opportunities to generate additional stack entries.
3913 if ((part_right - pc_right) > (pc_left - part_left)) {
3914 /* stack the right partition, process the left */
3915 partition_stack[next_stack_entry].left = pc_right + 1;
3916 partition_stack[next_stack_entry].right = part_right;
3917 #ifdef QSORT_ORDER_GUESS
3918 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3920 part_right = pc_left - 1;
3922 /* stack the left partition, process the right */
3923 partition_stack[next_stack_entry].left = part_left;
3924 partition_stack[next_stack_entry].right = pc_left - 1;
3925 #ifdef QSORT_ORDER_GUESS
3926 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3928 part_left = pc_right + 1;
3930 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3933 /* The elements on the left are the only remaining elements
3934 that need sorting, arrange for them to be processed as the
3937 part_right = pc_left - 1;
3939 } else if (pc_right < part_right) {
3940 /* There is only one chunk on the right to be sorted, make it
3941 the new partition and loop back around.
3943 part_left = pc_right + 1;
3945 /* This whole partition wound up in the pivot chunk, so
3946 we need to get a new partition off the stack.
3948 if (next_stack_entry == 0) {
3949 /* the stack is empty - we are done */
3953 part_left = partition_stack[next_stack_entry].left;
3954 part_right = partition_stack[next_stack_entry].right;
3955 #ifdef QSORT_ORDER_GUESS
3956 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3960 /* This partition is too small to fool with qsort complexity, just
3961 do an ordinary insertion sort to minimize overhead.
3964 /* Assume 1st element is in right place already, and start checking
3965 at 2nd element to see where it should be inserted.
3967 for (i = part_left + 1; i <= part_right; ++i) {
3969 /* Scan (backwards - just in case 'i' is already in right place)
3970 through the elements already sorted to see if the ith element
3971 belongs ahead of one of them.
3973 for (j = i - 1; j >= part_left; --j) {
3974 if (qsort_cmp(i, j) >= 0) {
3975 /* i belongs right after j
3982 /* Looks like we really need to move some things
3986 for (k = i - 1; k >= j; --k)
3987 array[k + 1] = array[k];
3992 /* That partition is now sorted, grab the next one, or get out
3993 of the loop if there aren't any more.
3996 if (next_stack_entry == 0) {
3997 /* the stack is empty - we are done */
4001 part_left = partition_stack[next_stack_entry].left;
4002 part_right = partition_stack[next_stack_entry].right;
4003 #ifdef QSORT_ORDER_GUESS
4004 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4009 /* Believe it or not, the array is sorted at this point! */