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);
2031 if (PL_op->op_flags & OPf_STACKED) {
2035 /* This egregious kludge implements goto &subroutine */
2036 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2038 register PERL_CONTEXT *cx;
2039 CV* cv = (CV*)SvRV(sv);
2043 int arg_was_real = 0;
2046 if (!CvROOT(cv) && !CvXSUB(cv)) {
2051 /* autoloaded stub? */
2052 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2054 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2055 GvNAMELEN(gv), FALSE);
2056 if (autogv && (cv = GvCV(autogv)))
2058 tmpstr = sv_newmortal();
2059 gv_efullname3(tmpstr, gv, Nullch);
2060 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2062 DIE("Goto undefined subroutine");
2065 /* First do some returnish stuff. */
2066 cxix = dopoptosub(cxstack_ix);
2068 DIE("Can't goto subroutine outside a subroutine");
2069 if (cxix < cxstack_ix)
2072 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2073 DIE("Can't goto subroutine from an eval-string");
2075 if (CxTYPE(cx) == CXt_SUB &&
2076 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2077 AV* av = cx->blk_sub.argarray;
2079 items = AvFILLp(av) + 1;
2081 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2082 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2083 PL_stack_sp += items;
2085 SvREFCNT_dec(GvAV(PL_defgv));
2086 GvAV(PL_defgv) = cx->blk_sub.savearray;
2087 #endif /* USE_THREADS */
2090 AvREAL_off(av); /* so av_clear() won't clobber elts */
2094 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2098 av = (AV*)PL_curpad[0];
2100 av = GvAV(PL_defgv);
2102 items = AvFILLp(av) + 1;
2104 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2105 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2106 PL_stack_sp += items;
2108 if (CxTYPE(cx) == CXt_SUB &&
2109 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2110 SvREFCNT_dec(cx->blk_sub.cv);
2111 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2112 LEAVE_SCOPE(oldsave);
2114 /* Now do some callish stuff. */
2117 if (CvOLDSTYLE(cv)) {
2118 I32 (*fp3)_((int,int,int));
2123 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2124 items = (*fp3)(CvXSUBANY(cv).any_i32,
2125 mark - PL_stack_base + 1,
2127 SP = PL_stack_base + items;
2133 PL_stack_sp--; /* There is no cv arg. */
2134 /* Push a mark for the start of arglist */
2136 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2137 /* Pop the current context like a decent sub should */
2138 POPBLOCK(cx, PL_curpm);
2139 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2142 return pop_return();
2145 AV* padlist = CvPADLIST(cv);
2146 SV** svp = AvARRAY(padlist);
2147 if (CxTYPE(cx) == CXt_EVAL) {
2148 PL_in_eval = cx->blk_eval.old_in_eval;
2149 PL_eval_root = cx->blk_eval.old_eval_root;
2150 cx->cx_type = CXt_SUB;
2151 cx->blk_sub.hasargs = 0;
2153 cx->blk_sub.cv = cv;
2154 cx->blk_sub.olddepth = CvDEPTH(cv);
2156 if (CvDEPTH(cv) < 2)
2157 (void)SvREFCNT_inc(cv);
2158 else { /* save temporaries on recursion? */
2159 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2160 sub_crush_depth(cv);
2161 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2162 AV *newpad = newAV();
2163 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2164 I32 ix = AvFILLp((AV*)svp[1]);
2165 svp = AvARRAY(svp[0]);
2166 for ( ;ix > 0; ix--) {
2167 if (svp[ix] != &PL_sv_undef) {
2168 char *name = SvPVX(svp[ix]);
2169 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2172 /* outer lexical or anon code */
2173 av_store(newpad, ix,
2174 SvREFCNT_inc(oldpad[ix]) );
2176 else { /* our own lexical */
2178 av_store(newpad, ix, sv = (SV*)newAV());
2179 else if (*name == '%')
2180 av_store(newpad, ix, sv = (SV*)newHV());
2182 av_store(newpad, ix, sv = NEWSV(0,0));
2187 av_store(newpad, ix, sv = NEWSV(0,0));
2191 if (cx->blk_sub.hasargs) {
2194 av_store(newpad, 0, (SV*)av);
2195 AvFLAGS(av) = AVf_REIFY;
2197 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2198 AvFILLp(padlist) = CvDEPTH(cv);
2199 svp = AvARRAY(padlist);
2203 if (!cx->blk_sub.hasargs) {
2204 AV* av = (AV*)PL_curpad[0];
2206 items = AvFILLp(av) + 1;
2208 /* Mark is at the end of the stack. */
2210 Copy(AvARRAY(av), SP + 1, items, SV*);
2215 #endif /* USE_THREADS */
2216 SAVESPTR(PL_curpad);
2217 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2219 if (cx->blk_sub.hasargs)
2220 #endif /* USE_THREADS */
2222 AV* av = (AV*)PL_curpad[0];
2226 cx->blk_sub.savearray = GvAV(PL_defgv);
2227 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2228 #endif /* USE_THREADS */
2229 cx->blk_sub.argarray = av;
2232 if (items >= AvMAX(av) + 1) {
2234 if (AvARRAY(av) != ary) {
2235 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2236 SvPVX(av) = (char*)ary;
2238 if (items >= AvMAX(av) + 1) {
2239 AvMAX(av) = items - 1;
2240 Renew(ary,items+1,SV*);
2242 SvPVX(av) = (char*)ary;
2245 Copy(mark,AvARRAY(av),items,SV*);
2246 AvFILLp(av) = items - 1;
2247 /* preserve @_ nature */
2258 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2260 * We do not care about using sv to call CV;
2261 * it's for informational purposes only.
2263 SV *sv = GvSV(PL_DBsub);
2266 if (PERLDB_SUB_NN) {
2267 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2270 gv_efullname3(sv, CvGV(cv), Nullch);
2273 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2274 PUSHMARK( PL_stack_sp );
2275 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2279 RETURNOP(CvSTART(cv));
2283 label = SvPV(sv,n_a);
2285 else if (PL_op->op_flags & OPf_SPECIAL) {
2287 DIE("goto must have label");
2290 label = cPVOP->op_pv;
2292 if (label && *label) {
2297 PL_lastgotoprobe = 0;
2299 for (ix = cxstack_ix; ix >= 0; ix--) {
2301 switch (CxTYPE(cx)) {
2303 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2306 gotoprobe = cx->blk_oldcop->op_sibling;
2312 gotoprobe = cx->blk_oldcop->op_sibling;
2314 gotoprobe = PL_main_root;
2317 if (CvDEPTH(cx->blk_sub.cv)) {
2318 gotoprobe = CvROOT(cx->blk_sub.cv);
2323 DIE("Can't \"goto\" outside a block");
2327 gotoprobe = PL_main_root;
2330 retop = dofindlabel(gotoprobe, label,
2331 enterops, enterops + GOTO_DEPTH);
2334 PL_lastgotoprobe = gotoprobe;
2337 DIE("Can't find label %s", label);
2339 /* pop unwanted frames */
2341 if (ix < cxstack_ix) {
2348 oldsave = PL_scopestack[PL_scopestack_ix];
2349 LEAVE_SCOPE(oldsave);
2352 /* push wanted frames */
2354 if (*enterops && enterops[1]) {
2356 for (ix = 1; enterops[ix]; ix++) {
2357 PL_op = enterops[ix];
2358 /* Eventually we may want to stack the needed arguments
2359 * for each op. For now, we punt on the hard ones. */
2360 if (PL_op->op_type == OP_ENTERITER)
2361 DIE("Can't \"goto\" into the middle of a foreach loop",
2363 (CALLOP->op_ppaddr)(ARGS);
2371 if (!retop) retop = PL_main_start;
2373 PL_restartop = retop;
2374 PL_do_undump = TRUE;
2378 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2379 PL_do_undump = FALSE;
2395 if (anum == 1 && VMSISH_EXIT)
2400 PUSHs(&PL_sv_undef);
2408 double value = SvNVx(GvSV(cCOP->cop_gv));
2409 register I32 match = I_32(value);
2412 if (((double)match) > value)
2413 --match; /* was fractional--truncate other way */
2415 match -= cCOP->uop.scop.scop_offset;
2418 else if (match > cCOP->uop.scop.scop_max)
2419 match = cCOP->uop.scop.scop_max;
2420 PL_op = cCOP->uop.scop.scop_next[match];
2430 PL_op = PL_op->op_next; /* can't assume anything */
2433 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2434 match -= cCOP->uop.scop.scop_offset;
2437 else if (match > cCOP->uop.scop.scop_max)
2438 match = cCOP->uop.scop.scop_max;
2439 PL_op = cCOP->uop.scop.scop_next[match];
2448 save_lines(AV *array, SV *sv)
2450 register char *s = SvPVX(sv);
2451 register char *send = SvPVX(sv) + SvCUR(sv);
2453 register I32 line = 1;
2455 while (s && s < send) {
2456 SV *tmpstr = NEWSV(85,0);
2458 sv_upgrade(tmpstr, SVt_PVMG);
2459 t = strchr(s, '\n');
2465 sv_setpvn(tmpstr, s, t - s);
2466 av_store(array, line++, tmpstr);
2481 assert(CATCH_GET == TRUE);
2482 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2486 default: /* topmost level handles it */
2495 PL_op = PL_restartop;
2508 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2509 /* sv Text to convert to OP tree. */
2510 /* startop op_free() this to undo. */
2511 /* code Short string id of the caller. */
2513 dSP; /* Make POPBLOCK work. */
2516 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2519 OP *oop = PL_op, *rop;
2520 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2526 /* switch to eval mode */
2528 if (PL_curcop == &PL_compiling) {
2529 SAVESPTR(PL_compiling.cop_stash);
2530 PL_compiling.cop_stash = PL_curstash;
2532 SAVESPTR(PL_compiling.cop_filegv);
2533 SAVEI16(PL_compiling.cop_line);
2534 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2535 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2536 PL_compiling.cop_line = 1;
2537 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2538 deleting the eval's FILEGV from the stash before gv_check() runs
2539 (i.e. before run-time proper). To work around the coredump that
2540 ensues, we always turn GvMULTI_on for any globals that were
2541 introduced within evals. See force_ident(). GSAR 96-10-12 */
2542 safestr = savepv(tmpbuf);
2543 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2545 #ifdef OP_IN_REGISTER
2553 PL_op->op_type = OP_ENTEREVAL;
2554 PL_op->op_flags = 0; /* Avoid uninit warning. */
2555 PUSHBLOCK(cx, CXt_EVAL, SP);
2556 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2557 rop = doeval(G_SCALAR, startop);
2558 POPBLOCK(cx,PL_curpm);
2561 (*startop)->op_type = OP_NULL;
2562 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2564 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2566 if (PL_curcop == &PL_compiling)
2567 PL_compiling.op_private = PL_hints;
2568 #ifdef OP_IN_REGISTER
2574 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2576 doeval(int gimme, OP** startop)
2589 /* set up a scratch pad */
2592 SAVESPTR(PL_curpad);
2593 SAVESPTR(PL_comppad);
2594 SAVESPTR(PL_comppad_name);
2595 SAVEI32(PL_comppad_name_fill);
2596 SAVEI32(PL_min_intro_pending);
2597 SAVEI32(PL_max_intro_pending);
2600 for (i = cxstack_ix - 1; i >= 0; i--) {
2601 PERL_CONTEXT *cx = &cxstack[i];
2602 if (CxTYPE(cx) == CXt_EVAL)
2604 else if (CxTYPE(cx) == CXt_SUB) {
2605 caller = cx->blk_sub.cv;
2610 SAVESPTR(PL_compcv);
2611 PL_compcv = (CV*)NEWSV(1104,0);
2612 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2613 CvUNIQUE_on(PL_compcv);
2615 CvOWNER(PL_compcv) = 0;
2616 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2617 MUTEX_INIT(CvMUTEXP(PL_compcv));
2618 #endif /* USE_THREADS */
2620 PL_comppad = newAV();
2621 av_push(PL_comppad, Nullsv);
2622 PL_curpad = AvARRAY(PL_comppad);
2623 PL_comppad_name = newAV();
2624 PL_comppad_name_fill = 0;
2625 PL_min_intro_pending = 0;
2628 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2629 PL_curpad[0] = (SV*)newAV();
2630 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2631 #endif /* USE_THREADS */
2633 comppadlist = newAV();
2634 AvREAL_off(comppadlist);
2635 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2636 av_store(comppadlist, 1, (SV*)PL_comppad);
2637 CvPADLIST(PL_compcv) = comppadlist;
2639 if (!saveop || saveop->op_type != OP_REQUIRE)
2640 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2642 SAVEFREESV(PL_compcv);
2644 /* make sure we compile in the right package */
2646 newstash = PL_curcop->cop_stash;
2647 if (PL_curstash != newstash) {
2648 SAVESPTR(PL_curstash);
2649 PL_curstash = newstash;
2651 SAVESPTR(PL_beginav);
2652 PL_beginav = newAV();
2653 SAVEFREESV(PL_beginav);
2655 /* try to compile it */
2657 PL_eval_root = Nullop;
2659 PL_curcop = &PL_compiling;
2660 PL_curcop->cop_arybase = 0;
2661 SvREFCNT_dec(PL_rs);
2662 PL_rs = newSVpv("\n", 1);
2663 if (saveop && saveop->op_flags & OPf_SPECIAL)
2667 if (yyparse() || PL_error_count || !PL_eval_root) {
2671 I32 optype = 0; /* Might be reset by POPEVAL. */
2676 op_free(PL_eval_root);
2677 PL_eval_root = Nullop;
2679 SP = PL_stack_base + POPMARK; /* pop original mark */
2681 POPBLOCK(cx,PL_curpm);
2687 if (optype == OP_REQUIRE) {
2688 char* msg = SvPVx(ERRSV, n_a);
2689 DIE("%s", *msg ? msg : "Compilation failed in require");
2690 } else if (startop) {
2691 char* msg = SvPVx(ERRSV, n_a);
2693 POPBLOCK(cx,PL_curpm);
2695 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2697 SvREFCNT_dec(PL_rs);
2698 PL_rs = SvREFCNT_inc(PL_nrs);
2700 MUTEX_LOCK(&PL_eval_mutex);
2702 COND_SIGNAL(&PL_eval_cond);
2703 MUTEX_UNLOCK(&PL_eval_mutex);
2704 #endif /* USE_THREADS */
2707 SvREFCNT_dec(PL_rs);
2708 PL_rs = SvREFCNT_inc(PL_nrs);
2709 PL_compiling.cop_line = 0;
2711 *startop = PL_eval_root;
2712 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2713 CvOUTSIDE(PL_compcv) = Nullcv;
2715 SAVEFREEOP(PL_eval_root);
2717 scalarvoid(PL_eval_root);
2718 else if (gimme & G_ARRAY)
2721 scalar(PL_eval_root);
2723 DEBUG_x(dump_eval());
2725 /* Register with debugger: */
2726 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2727 CV *cv = perl_get_cv("DB::postponed", FALSE);
2731 XPUSHs((SV*)PL_compiling.cop_filegv);
2733 perl_call_sv((SV*)cv, G_DISCARD);
2737 /* compiled okay, so do it */
2739 CvDEPTH(PL_compcv) = 1;
2740 SP = PL_stack_base + POPMARK; /* pop original mark */
2741 PL_op = saveop; /* The caller may need it. */
2743 MUTEX_LOCK(&PL_eval_mutex);
2745 COND_SIGNAL(&PL_eval_cond);
2746 MUTEX_UNLOCK(&PL_eval_mutex);
2747 #endif /* USE_THREADS */
2749 RETURNOP(PL_eval_start);
2755 register PERL_CONTEXT *cx;
2760 SV *namesv = Nullsv;
2762 I32 gimme = G_SCALAR;
2763 PerlIO *tryrsfp = 0;
2767 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2768 SET_NUMERIC_STANDARD();
2769 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2770 DIE("Perl %s required--this is only version %s, stopped",
2771 SvPV(sv,n_a),PL_patchlevel);
2774 name = SvPV(sv, len);
2775 if (!(name && len > 0 && *name))
2776 DIE("Null filename used");
2777 TAINT_PROPER("require");
2778 if (PL_op->op_type == OP_REQUIRE &&
2779 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2780 *svp != &PL_sv_undef)
2783 /* prepare to compile file */
2788 (name[1] == '.' && name[2] == '/')))
2790 || (name[0] && name[1] == ':')
2793 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2796 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2797 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2802 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2805 AV *ar = GvAVn(PL_incgv);
2809 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2812 namesv = NEWSV(806, 0);
2813 for (i = 0; i <= AvFILL(ar); i++) {
2814 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2817 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2819 sv_setpv(namesv, unixdir);
2820 sv_catpv(namesv, unixname);
2822 sv_setpvf(namesv, "%s/%s", dir, name);
2824 TAINT_PROPER("require");
2825 tryname = SvPVX(namesv);
2826 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2828 if (tryname[0] == '.' && tryname[1] == '/')
2835 SAVESPTR(PL_compiling.cop_filegv);
2836 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2837 SvREFCNT_dec(namesv);
2839 if (PL_op->op_type == OP_REQUIRE) {
2840 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2841 SV *dirmsgsv = NEWSV(0, 0);
2842 AV *ar = GvAVn(PL_incgv);
2844 if (instr(SvPVX(msg), ".h "))
2845 sv_catpv(msg, " (change .h to .ph maybe?)");
2846 if (instr(SvPVX(msg), ".ph "))
2847 sv_catpv(msg, " (did you run h2ph?)");
2848 sv_catpv(msg, " (@INC contains:");
2849 for (i = 0; i <= AvFILL(ar); i++) {
2850 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2851 sv_setpvf(dirmsgsv, " %s", dir);
2852 sv_catsv(msg, dirmsgsv);
2854 sv_catpvn(msg, ")", 1);
2855 SvREFCNT_dec(dirmsgsv);
2862 SETERRNO(0, SS$_NORMAL);
2864 /* Assume success here to prevent recursive requirement. */
2865 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2866 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2870 lex_start(sv_2mortal(newSVpv("",0)));
2871 SAVEGENERICSV(PL_rsfp_filters);
2872 PL_rsfp_filters = Nullav;
2875 name = savepv(name);
2879 SAVEPPTR(PL_compiling.cop_warnings);
2880 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2883 /* switch to eval mode */
2885 push_return(PL_op->op_next);
2886 PUSHBLOCK(cx, CXt_EVAL, SP);
2887 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2889 SAVEI16(PL_compiling.cop_line);
2890 PL_compiling.cop_line = 0;
2894 MUTEX_LOCK(&PL_eval_mutex);
2895 if (PL_eval_owner && PL_eval_owner != thr)
2896 while (PL_eval_owner)
2897 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2898 PL_eval_owner = thr;
2899 MUTEX_UNLOCK(&PL_eval_mutex);
2900 #endif /* USE_THREADS */
2901 return DOCATCH(doeval(G_SCALAR, NULL));
2906 return pp_require(ARGS);
2912 register PERL_CONTEXT *cx;
2914 I32 gimme = GIMME_V, was = PL_sub_generation;
2915 char tmpbuf[TYPE_DIGITS(long) + 12];
2920 if (!SvPV(sv,len) || !len)
2922 TAINT_PROPER("eval");
2928 /* switch to eval mode */
2930 SAVESPTR(PL_compiling.cop_filegv);
2931 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2932 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2933 PL_compiling.cop_line = 1;
2934 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2935 deleting the eval's FILEGV from the stash before gv_check() runs
2936 (i.e. before run-time proper). To work around the coredump that
2937 ensues, we always turn GvMULTI_on for any globals that were
2938 introduced within evals. See force_ident(). GSAR 96-10-12 */
2939 safestr = savepv(tmpbuf);
2940 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2942 PL_hints = PL_op->op_targ;
2943 SAVEPPTR(PL_compiling.cop_warnings);
2944 if (PL_compiling.cop_warnings != WARN_ALL
2945 && PL_compiling.cop_warnings != WARN_NONE){
2946 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2947 SAVEFREESV(PL_compiling.cop_warnings) ;
2950 push_return(PL_op->op_next);
2951 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2952 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2954 /* prepare to compile string */
2956 if (PERLDB_LINE && PL_curstash != PL_debstash)
2957 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2960 MUTEX_LOCK(&PL_eval_mutex);
2961 if (PL_eval_owner && PL_eval_owner != thr)
2962 while (PL_eval_owner)
2963 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2964 PL_eval_owner = thr;
2965 MUTEX_UNLOCK(&PL_eval_mutex);
2966 #endif /* USE_THREADS */
2967 ret = doeval(gimme, NULL);
2968 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2969 && ret != PL_op->op_next) { /* Successive compilation. */
2970 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2972 return DOCATCH(ret);
2982 register PERL_CONTEXT *cx;
2984 U8 save_flags = PL_op -> op_flags;
2989 retop = pop_return();
2992 if (gimme == G_VOID)
2994 else if (gimme == G_SCALAR) {
2997 if (SvFLAGS(TOPs) & SVs_TEMP)
3000 *MARK = sv_mortalcopy(TOPs);
3004 *MARK = &PL_sv_undef;
3008 /* in case LEAVE wipes old return values */
3009 for (mark = newsp + 1; mark <= SP; mark++) {
3010 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3011 *mark = sv_mortalcopy(*mark);
3012 TAINT_NOT; /* Each item is independent */
3016 PL_curpm = newpm; /* Don't pop $1 et al till now */
3019 * Closures mentioned at top level of eval cannot be referenced
3020 * again, and their presence indirectly causes a memory leak.
3021 * (Note that the fact that compcv and friends are still set here
3022 * is, AFAIK, an accident.) --Chip
3024 if (AvFILLp(PL_comppad_name) >= 0) {
3025 SV **svp = AvARRAY(PL_comppad_name);
3027 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3029 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3031 svp[ix] = &PL_sv_undef;
3035 SvREFCNT_dec(CvOUTSIDE(sv));
3036 CvOUTSIDE(sv) = Nullcv;
3049 assert(CvDEPTH(PL_compcv) == 1);
3051 CvDEPTH(PL_compcv) = 0;
3054 if (optype == OP_REQUIRE &&
3055 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3057 /* Unassume the success we assumed earlier. */
3058 char *name = cx->blk_eval.old_name;
3059 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3060 retop = die("%s did not return a true value", name);
3061 /* die_where() did LEAVE, or we won't be here */
3065 if (!(save_flags & OPf_SPECIAL))
3075 register PERL_CONTEXT *cx;
3076 I32 gimme = GIMME_V;
3081 push_return(cLOGOP->op_other->op_next);
3082 PUSHBLOCK(cx, CXt_EVAL, SP);
3084 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3089 return DOCATCH(PL_op->op_next);
3099 register PERL_CONTEXT *cx;
3107 if (gimme == G_VOID)
3109 else if (gimme == G_SCALAR) {
3112 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3115 *MARK = sv_mortalcopy(TOPs);
3119 *MARK = &PL_sv_undef;
3124 /* in case LEAVE wipes old return values */
3125 for (mark = newsp + 1; mark <= SP; mark++) {
3126 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3127 *mark = sv_mortalcopy(*mark);
3128 TAINT_NOT; /* Each item is independent */
3132 PL_curpm = newpm; /* Don't pop $1 et al till now */
3143 register char *s = SvPV_force(sv, len);
3144 register char *send = s + len;
3145 register char *base;
3146 register I32 skipspaces = 0;
3149 bool postspace = FALSE;
3157 croak("Null picture in formline");
3159 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3164 *fpc++ = FF_LINEMARK;
3165 noblank = repeat = FALSE;
3183 case ' ': case '\t':
3194 *fpc++ = FF_LITERAL;
3202 *fpc++ = skipspaces;
3206 *fpc++ = FF_NEWLINE;
3210 arg = fpc - linepc + 1;
3217 *fpc++ = FF_LINEMARK;
3218 noblank = repeat = FALSE;
3227 ischop = s[-1] == '^';
3233 arg = (s - base) - 1;
3235 *fpc++ = FF_LITERAL;
3244 *fpc++ = FF_LINEGLOB;
3246 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3247 arg = ischop ? 512 : 0;
3257 arg |= 256 + (s - f);
3259 *fpc++ = s - base; /* fieldsize for FETCH */
3260 *fpc++ = FF_DECIMAL;
3265 bool ismore = FALSE;
3268 while (*++s == '>') ;
3269 prespace = FF_SPACE;
3271 else if (*s == '|') {
3272 while (*++s == '|') ;
3273 prespace = FF_HALFSPACE;
3278 while (*++s == '<') ;
3281 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3285 *fpc++ = s - base; /* fieldsize for FETCH */
3287 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3305 { /* need to jump to the next word */
3307 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3308 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3309 s = SvPVX(sv) + SvCUR(sv) + z;
3311 Copy(fops, s, arg, U16);
3313 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3318 * The rest of this file was derived from source code contributed
3321 * NOTE: this code was derived from Tom Horsley's qsort replacement
3322 * and should not be confused with the original code.
3325 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3327 Permission granted to distribute under the same terms as perl which are
3330 This program is free software; you can redistribute it and/or modify
3331 it under the terms of either:
3333 a) the GNU General Public License as published by the Free
3334 Software Foundation; either version 1, or (at your option) any
3337 b) the "Artistic License" which comes with this Kit.
3339 Details on the perl license can be found in the perl source code which
3340 may be located via the www.perl.com web page.
3342 This is the most wonderfulest possible qsort I can come up with (and
3343 still be mostly portable) My (limited) tests indicate it consistently
3344 does about 20% fewer calls to compare than does the qsort in the Visual
3345 C++ library, other vendors may vary.
3347 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3348 others I invented myself (or more likely re-invented since they seemed
3349 pretty obvious once I watched the algorithm operate for a while).
3351 Most of this code was written while watching the Marlins sweep the Giants
3352 in the 1997 National League Playoffs - no Braves fans allowed to use this
3353 code (just kidding :-).
3355 I realize that if I wanted to be true to the perl tradition, the only
3356 comment in this file would be something like:
3358 ...they shuffled back towards the rear of the line. 'No, not at the
3359 rear!' the slave-driver shouted. 'Three files up. And stay there...
3361 However, I really needed to violate that tradition just so I could keep
3362 track of what happens myself, not to mention some poor fool trying to
3363 understand this years from now :-).
3366 /* ********************************************************** Configuration */
3368 #ifndef QSORT_ORDER_GUESS
3369 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3372 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3373 future processing - a good max upper bound is log base 2 of memory size
3374 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3375 safely be smaller than that since the program is taking up some space and
3376 most operating systems only let you grab some subset of contiguous
3377 memory (not to mention that you are normally sorting data larger than
3378 1 byte element size :-).
3380 #ifndef QSORT_MAX_STACK
3381 #define QSORT_MAX_STACK 32
3384 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3385 Anything bigger and we use qsort. If you make this too small, the qsort
3386 will probably break (or become less efficient), because it doesn't expect
3387 the middle element of a partition to be the same as the right or left -
3388 you have been warned).
3390 #ifndef QSORT_BREAK_EVEN
3391 #define QSORT_BREAK_EVEN 6
3394 /* ************************************************************* Data Types */
3396 /* hold left and right index values of a partition waiting to be sorted (the
3397 partition includes both left and right - right is NOT one past the end or
3398 anything like that).
3400 struct partition_stack_entry {
3403 #ifdef QSORT_ORDER_GUESS
3404 int qsort_break_even;
3408 /* ******************************************************* Shorthand Macros */
3410 /* Note that these macros will be used from inside the qsort function where
3411 we happen to know that the variable 'elt_size' contains the size of an
3412 array element and the variable 'temp' points to enough space to hold a
3413 temp element and the variable 'array' points to the array being sorted
3414 and 'compare' is the pointer to the compare routine.
3416 Also note that there are very many highly architecture specific ways
3417 these might be sped up, but this is simply the most generally portable
3418 code I could think of.
3421 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3424 #define qsort_cmp(elt1, elt2) \
3425 ((this->*compare)(array[elt1], array[elt2]))
3427 #define qsort_cmp(elt1, elt2) \
3428 ((*compare)(array[elt1], array[elt2]))
3431 #ifdef QSORT_ORDER_GUESS
3432 #define QSORT_NOTICE_SWAP swapped++;
3434 #define QSORT_NOTICE_SWAP
3437 /* swaps contents of array elements elt1, elt2.
3439 #define qsort_swap(elt1, elt2) \
3442 temp = array[elt1]; \
3443 array[elt1] = array[elt2]; \
3444 array[elt2] = temp; \
3447 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3448 elt3 and elt3 gets elt1.
3450 #define qsort_rotate(elt1, elt2, elt3) \
3453 temp = array[elt1]; \
3454 array[elt1] = array[elt2]; \
3455 array[elt2] = array[elt3]; \
3456 array[elt3] = temp; \
3459 /* ************************************************************ Debug stuff */
3466 return; /* good place to set a breakpoint */
3469 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3472 doqsort_all_asserts(
3476 int (*compare)(const void * elt1, const void * elt2),
3477 int pc_left, int pc_right, int u_left, int u_right)
3481 qsort_assert(pc_left <= pc_right);
3482 qsort_assert(u_right < pc_left);
3483 qsort_assert(pc_right < u_left);
3484 for (i = u_right + 1; i < pc_left; ++i) {
3485 qsort_assert(qsort_cmp(i, pc_left) < 0);
3487 for (i = pc_left; i < pc_right; ++i) {
3488 qsort_assert(qsort_cmp(i, pc_right) == 0);
3490 for (i = pc_right + 1; i < u_left; ++i) {
3491 qsort_assert(qsort_cmp(pc_right, i) < 0);
3495 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3496 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3497 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3501 #define qsort_assert(t) ((void)0)
3503 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3507 /* ****************************************************************** qsort */
3511 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3516 I32 (*compare)(SV *a, SV *b))
3521 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3522 int next_stack_entry = 0;
3526 #ifdef QSORT_ORDER_GUESS
3527 int qsort_break_even;
3531 /* Make sure we actually have work to do.
3533 if (num_elts <= 1) {
3537 /* Setup the initial partition definition and fall into the sorting loop
3540 part_right = (int)(num_elts - 1);
3541 #ifdef QSORT_ORDER_GUESS
3542 qsort_break_even = QSORT_BREAK_EVEN;
3544 #define qsort_break_even QSORT_BREAK_EVEN
3547 if ((part_right - part_left) >= qsort_break_even) {
3548 /* OK, this is gonna get hairy, so lets try to document all the
3549 concepts and abbreviations and variables and what they keep
3552 pc: pivot chunk - the set of array elements we accumulate in the
3553 middle of the partition, all equal in value to the original
3554 pivot element selected. The pc is defined by:
3556 pc_left - the leftmost array index of the pc
3557 pc_right - the rightmost array index of the pc
3559 we start with pc_left == pc_right and only one element
3560 in the pivot chunk (but it can grow during the scan).
3562 u: uncompared elements - the set of elements in the partition
3563 we have not yet compared to the pivot value. There are two
3564 uncompared sets during the scan - one to the left of the pc
3565 and one to the right.
3567 u_right - the rightmost index of the left side's uncompared set
3568 u_left - the leftmost index of the right side's uncompared set
3570 The leftmost index of the left sides's uncompared set
3571 doesn't need its own variable because it is always defined
3572 by the leftmost edge of the whole partition (part_left). The
3573 same goes for the rightmost edge of the right partition
3576 We know there are no uncompared elements on the left once we
3577 get u_right < part_left and no uncompared elements on the
3578 right once u_left > part_right. When both these conditions
3579 are met, we have completed the scan of the partition.
3581 Any elements which are between the pivot chunk and the
3582 uncompared elements should be less than the pivot value on
3583 the left side and greater than the pivot value on the right
3584 side (in fact, the goal of the whole algorithm is to arrange
3585 for that to be true and make the groups of less-than and
3586 greater-then elements into new partitions to sort again).
3588 As you marvel at the complexity of the code and wonder why it
3589 has to be so confusing. Consider some of the things this level
3590 of confusion brings:
3592 Once I do a compare, I squeeze every ounce of juice out of it. I
3593 never do compare calls I don't have to do, and I certainly never
3596 I also never swap any elements unless I can prove there is a
3597 good reason. Many sort algorithms will swap a known value with
3598 an uncompared value just to get things in the right place (or
3599 avoid complexity :-), but that uncompared value, once it gets
3600 compared, may then have to be swapped again. A lot of the
3601 complexity of this code is due to the fact that it never swaps
3602 anything except compared values, and it only swaps them when the
3603 compare shows they are out of position.
3605 int pc_left, pc_right;
3606 int u_right, u_left;
3610 pc_left = ((part_left + part_right) / 2);
3612 u_right = pc_left - 1;
3613 u_left = pc_right + 1;
3615 /* Qsort works best when the pivot value is also the median value
3616 in the partition (unfortunately you can't find the median value
3617 without first sorting :-), so to give the algorithm a helping
3618 hand, we pick 3 elements and sort them and use the median value
3619 of that tiny set as the pivot value.
3621 Some versions of qsort like to use the left middle and right as
3622 the 3 elements to sort so they can insure the ends of the
3623 partition will contain values which will stop the scan in the
3624 compare loop, but when you have to call an arbitrarily complex
3625 routine to do a compare, its really better to just keep track of
3626 array index values to know when you hit the edge of the
3627 partition and avoid the extra compare. An even better reason to
3628 avoid using a compare call is the fact that you can drop off the
3629 edge of the array if someone foolishly provides you with an
3630 unstable compare function that doesn't always provide consistent
3633 So, since it is simpler for us to compare the three adjacent
3634 elements in the middle of the partition, those are the ones we
3635 pick here (conveniently pointed at by u_right, pc_left, and
3636 u_left). The values of the left, center, and right elements
3637 are refered to as l c and r in the following comments.
3640 #ifdef QSORT_ORDER_GUESS
3643 s = qsort_cmp(u_right, pc_left);
3646 s = qsort_cmp(pc_left, u_left);
3647 /* if l < c, c < r - already in order - nothing to do */
3649 /* l < c, c == r - already in order, pc grows */
3651 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3653 /* l < c, c > r - need to know more */
3654 s = qsort_cmp(u_right, u_left);
3656 /* l < c, c > r, l < r - swap c & r to get ordered */
3657 qsort_swap(pc_left, u_left);
3658 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3659 } else if (s == 0) {
3660 /* l < c, c > r, l == r - swap c&r, grow pc */
3661 qsort_swap(pc_left, u_left);
3663 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3665 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3666 qsort_rotate(pc_left, u_right, u_left);
3667 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3670 } else if (s == 0) {
3672 s = qsort_cmp(pc_left, u_left);
3674 /* l == c, c < r - already in order, grow pc */
3676 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3677 } else if (s == 0) {
3678 /* l == c, c == r - already in order, grow pc both ways */
3681 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3683 /* l == c, c > r - swap l & r, grow pc */
3684 qsort_swap(u_right, u_left);
3686 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3690 s = qsort_cmp(pc_left, u_left);
3692 /* l > c, c < r - need to know more */
3693 s = qsort_cmp(u_right, u_left);
3695 /* l > c, c < r, l < r - swap l & c to get ordered */
3696 qsort_swap(u_right, pc_left);
3697 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3698 } else if (s == 0) {
3699 /* l > c, c < r, l == r - swap l & c, grow pc */
3700 qsort_swap(u_right, pc_left);
3702 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3704 /* l > c, c < r, l > r - rotate lcr into crl to order */
3705 qsort_rotate(u_right, pc_left, u_left);
3706 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3708 } else if (s == 0) {
3709 /* l > c, c == r - swap ends, grow pc */
3710 qsort_swap(u_right, u_left);
3712 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3714 /* l > c, c > r - swap ends to get in order */
3715 qsort_swap(u_right, u_left);
3716 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3719 /* We now know the 3 middle elements have been compared and
3720 arranged in the desired order, so we can shrink the uncompared
3725 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3727 /* The above massive nested if was the simple part :-). We now have
3728 the middle 3 elements ordered and we need to scan through the
3729 uncompared sets on either side, swapping elements that are on
3730 the wrong side or simply shuffling equal elements around to get
3731 all equal elements into the pivot chunk.
3735 int still_work_on_left;
3736 int still_work_on_right;
3738 /* Scan the uncompared values on the left. If I find a value
3739 equal to the pivot value, move it over so it is adjacent to
3740 the pivot chunk and expand the pivot chunk. If I find a value
3741 less than the pivot value, then just leave it - its already
3742 on the correct side of the partition. If I find a greater
3743 value, then stop the scan.
3745 while (still_work_on_left = (u_right >= part_left)) {
3746 s = qsort_cmp(u_right, pc_left);
3749 } else if (s == 0) {
3751 if (pc_left != u_right) {
3752 qsort_swap(u_right, pc_left);
3758 qsort_assert(u_right < pc_left);
3759 qsort_assert(pc_left <= pc_right);
3760 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3761 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3764 /* Do a mirror image scan of uncompared values on the right
3766 while (still_work_on_right = (u_left <= part_right)) {
3767 s = qsort_cmp(pc_right, u_left);
3770 } else if (s == 0) {
3772 if (pc_right != u_left) {
3773 qsort_swap(pc_right, u_left);
3779 qsort_assert(u_left > pc_right);
3780 qsort_assert(pc_left <= pc_right);
3781 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3782 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3785 if (still_work_on_left) {
3786 /* I know I have a value on the left side which needs to be
3787 on the right side, but I need to know more to decide
3788 exactly the best thing to do with it.
3790 if (still_work_on_right) {
3791 /* I know I have values on both side which are out of
3792 position. This is a big win because I kill two birds
3793 with one swap (so to speak). I can advance the
3794 uncompared pointers on both sides after swapping both
3795 of them into the right place.
3797 qsort_swap(u_right, u_left);
3800 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3802 /* I have an out of position value on the left, but the
3803 right is fully scanned, so I "slide" the pivot chunk
3804 and any less-than values left one to make room for the
3805 greater value over on the right. If the out of position
3806 value is immediately adjacent to the pivot chunk (there
3807 are no less-than values), I can do that with a swap,
3808 otherwise, I have to rotate one of the less than values
3809 into the former position of the out of position value
3810 and the right end of the pivot chunk into the left end
3814 if (pc_left == u_right) {
3815 qsort_swap(u_right, pc_right);
3816 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3818 qsort_rotate(u_right, pc_left, pc_right);
3819 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3824 } else if (still_work_on_right) {
3825 /* Mirror image of complex case above: I have an out of
3826 position value on the right, but the left is fully
3827 scanned, so I need to shuffle things around to make room
3828 for the right value on the left.
3831 if (pc_right == u_left) {
3832 qsort_swap(u_left, pc_left);
3833 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3835 qsort_rotate(pc_right, pc_left, u_left);
3836 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3841 /* No more scanning required on either side of partition,
3842 break out of loop and figure out next set of partitions
3848 /* The elements in the pivot chunk are now in the right place. They
3849 will never move or be compared again. All I have to do is decide
3850 what to do with the stuff to the left and right of the pivot
3853 Notes on the QSORT_ORDER_GUESS ifdef code:
3855 1. If I just built these partitions without swapping any (or
3856 very many) elements, there is a chance that the elements are
3857 already ordered properly (being properly ordered will
3858 certainly result in no swapping, but the converse can't be
3861 2. A (properly written) insertion sort will run faster on
3862 already ordered data than qsort will.
3864 3. Perhaps there is some way to make a good guess about
3865 switching to an insertion sort earlier than partition size 6
3866 (for instance - we could save the partition size on the stack
3867 and increase the size each time we find we didn't swap, thus
3868 switching to insertion sort earlier for partitions with a
3869 history of not swapping).
3871 4. Naturally, if I just switch right away, it will make
3872 artificial benchmarks with pure ascending (or descending)
3873 data look really good, but is that a good reason in general?
3877 #ifdef QSORT_ORDER_GUESS
3879 #if QSORT_ORDER_GUESS == 1
3880 qsort_break_even = (part_right - part_left) + 1;
3882 #if QSORT_ORDER_GUESS == 2
3883 qsort_break_even *= 2;
3885 #if QSORT_ORDER_GUESS == 3
3886 int prev_break = qsort_break_even;
3887 qsort_break_even *= qsort_break_even;
3888 if (qsort_break_even < prev_break) {
3889 qsort_break_even = (part_right - part_left) + 1;
3893 qsort_break_even = QSORT_BREAK_EVEN;
3897 if (part_left < pc_left) {
3898 /* There are elements on the left which need more processing.
3899 Check the right as well before deciding what to do.
3901 if (pc_right < part_right) {
3902 /* We have two partitions to be sorted. Stack the biggest one
3903 and process the smallest one on the next iteration. This
3904 minimizes the stack height by insuring that any additional
3905 stack entries must come from the smallest partition which
3906 (because it is smallest) will have the fewest
3907 opportunities to generate additional stack entries.
3909 if ((part_right - pc_right) > (pc_left - part_left)) {
3910 /* stack the right partition, process the left */
3911 partition_stack[next_stack_entry].left = pc_right + 1;
3912 partition_stack[next_stack_entry].right = part_right;
3913 #ifdef QSORT_ORDER_GUESS
3914 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3916 part_right = pc_left - 1;
3918 /* stack the left partition, process the right */
3919 partition_stack[next_stack_entry].left = part_left;
3920 partition_stack[next_stack_entry].right = pc_left - 1;
3921 #ifdef QSORT_ORDER_GUESS
3922 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3924 part_left = pc_right + 1;
3926 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3929 /* The elements on the left are the only remaining elements
3930 that need sorting, arrange for them to be processed as the
3933 part_right = pc_left - 1;
3935 } else if (pc_right < part_right) {
3936 /* There is only one chunk on the right to be sorted, make it
3937 the new partition and loop back around.
3939 part_left = pc_right + 1;
3941 /* This whole partition wound up in the pivot chunk, so
3942 we need to get a new partition off the stack.
3944 if (next_stack_entry == 0) {
3945 /* the stack is empty - we are done */
3949 part_left = partition_stack[next_stack_entry].left;
3950 part_right = partition_stack[next_stack_entry].right;
3951 #ifdef QSORT_ORDER_GUESS
3952 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3956 /* This partition is too small to fool with qsort complexity, just
3957 do an ordinary insertion sort to minimize overhead.
3960 /* Assume 1st element is in right place already, and start checking
3961 at 2nd element to see where it should be inserted.
3963 for (i = part_left + 1; i <= part_right; ++i) {
3965 /* Scan (backwards - just in case 'i' is already in right place)
3966 through the elements already sorted to see if the ith element
3967 belongs ahead of one of them.
3969 for (j = i - 1; j >= part_left; --j) {
3970 if (qsort_cmp(i, j) >= 0) {
3971 /* i belongs right after j
3978 /* Looks like we really need to move some things
3982 for (k = i - 1; k >= j; --k)
3983 array[k + 1] = array[k];
3988 /* That partition is now sorted, grab the next one, or get out
3989 of the loop if there aren't any more.
3992 if (next_stack_entry == 0) {
3993 /* the stack is empty - we are done */
3997 part_left = partition_stack[next_stack_entry].left;
3998 part_right = partition_stack[next_stack_entry].right;
3999 #ifdef QSORT_ORDER_GUESS
4000 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4005 /* Believe it or not, the array is sorted at this point! */