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 (SvGMAGICAL(left))
1074 if (SvGMAGICAL(right))
1077 if (SvNIOKp(left) || !SvPOKp(left) ||
1078 (looks_like_number(left) && *SvPVX(left) != '0') )
1080 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1081 croak("Range iterator outside integer range");
1092 sv = sv_2mortal(newSViv(i++));
1097 SV *final = sv_mortalcopy(right);
1099 char *tmps = SvPV(final, len);
1101 sv = sv_mortalcopy(left);
1103 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1105 if (strEQ(SvPVX(sv),tmps))
1107 sv = sv_2mortal(newSVsv(sv));
1114 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1116 if ((PL_op->op_private & OPpFLIP_LINENUM)
1117 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1119 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1120 sv_catpv(targ, "E0");
1131 dopoptolabel(char *label)
1135 register PERL_CONTEXT *cx;
1137 for (i = cxstack_ix; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1141 if (ckWARN(WARN_UNSAFE))
1142 warner(WARN_UNSAFE, "Exiting substitution via %s",
1143 PL_op_name[PL_op->op_type]);
1146 if (ckWARN(WARN_UNSAFE))
1147 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1148 PL_op_name[PL_op->op_type]);
1151 if (ckWARN(WARN_UNSAFE))
1152 warner(WARN_UNSAFE, "Exiting eval via %s",
1153 PL_op_name[PL_op->op_type]);
1156 if (ckWARN(WARN_UNSAFE))
1157 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1158 PL_op_name[PL_op->op_type]);
1161 if (!cx->blk_loop.label ||
1162 strNE(label, cx->blk_loop.label) ) {
1163 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1164 (long)i, cx->blk_loop.label));
1167 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1177 I32 gimme = block_gimme();
1178 return (gimme == G_VOID) ? G_SCALAR : gimme;
1187 cxix = dopoptosub(cxstack_ix);
1191 switch (cxstack[cxix].blk_gimme) {
1199 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1206 dopoptosub(I32 startingblock)
1209 return dopoptosub_at(cxstack, startingblock);
1213 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1217 register PERL_CONTEXT *cx;
1218 for (i = startingblock; i >= 0; i--) {
1220 switch (CxTYPE(cx)) {
1225 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1233 dopoptoeval(I32 startingblock)
1237 register PERL_CONTEXT *cx;
1238 for (i = startingblock; i >= 0; i--) {
1240 switch (CxTYPE(cx)) {
1244 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1252 dopoptoloop(I32 startingblock)
1256 register PERL_CONTEXT *cx;
1257 for (i = startingblock; i >= 0; i--) {
1259 switch (CxTYPE(cx)) {
1261 if (ckWARN(WARN_UNSAFE))
1262 warner(WARN_UNSAFE, "Exiting substitution via %s",
1263 PL_op_name[PL_op->op_type]);
1266 if (ckWARN(WARN_UNSAFE))
1267 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1268 PL_op_name[PL_op->op_type]);
1271 if (ckWARN(WARN_UNSAFE))
1272 warner(WARN_UNSAFE, "Exiting eval via %s",
1273 PL_op_name[PL_op->op_type]);
1276 if (ckWARN(WARN_UNSAFE))
1277 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1278 PL_op_name[PL_op->op_type]);
1281 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1292 register PERL_CONTEXT *cx;
1296 while (cxstack_ix > cxix) {
1297 cx = &cxstack[cxstack_ix];
1298 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1299 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1300 /* Note: we don't need to restore the base context info till the end. */
1301 switch (CxTYPE(cx)) {
1304 continue; /* not break */
1322 die_where(char *message)
1328 register PERL_CONTEXT *cx;
1333 if (PL_in_eval & 4) {
1335 STRLEN klen = strlen(message);
1337 svp = hv_fetch(ERRHV, message, klen, TRUE);
1340 static char prefix[] = "\t(in cleanup) ";
1342 sv_upgrade(*svp, SVt_IV);
1343 (void)SvIOK_only(*svp);
1346 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1347 sv_catpvn(err, prefix, sizeof(prefix)-1);
1348 sv_catpvn(err, message, klen);
1349 if (ckWARN(WARN_UNSAFE)) {
1350 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1351 warner(WARN_UNSAFE, SvPVX(err)+start);
1358 sv_setpv(ERRSV, message);
1361 message = SvPVx(ERRSV, n_a);
1363 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1371 if (cxix < cxstack_ix)
1374 POPBLOCK(cx,PL_curpm);
1375 if (CxTYPE(cx) != CXt_EVAL) {
1376 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1381 if (gimme == G_SCALAR)
1382 *++newsp = &PL_sv_undef;
1383 PL_stack_sp = newsp;
1387 if (optype == OP_REQUIRE) {
1388 char* msg = SvPVx(ERRSV, n_a);
1389 DIE("%s", *msg ? msg : "Compilation failed in require");
1391 return pop_return();
1395 message = SvPVx(ERRSV, n_a);
1396 PerlIO_printf(PerlIO_stderr(), "%s",message);
1397 PerlIO_flush(PerlIO_stderr());
1406 if (SvTRUE(left) != SvTRUE(right))
1418 RETURNOP(cLOGOP->op_other);
1427 RETURNOP(cLOGOP->op_other);
1433 register I32 cxix = dopoptosub(cxstack_ix);
1434 register PERL_CONTEXT *cx;
1435 register PERL_CONTEXT *ccstack = cxstack;
1436 PERL_SI *top_si = PL_curstackinfo;
1447 /* we may be in a higher stacklevel, so dig down deeper */
1448 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1449 top_si = top_si->si_prev;
1450 ccstack = top_si->si_cxstack;
1451 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1454 if (GIMME != G_ARRAY)
1458 if (PL_DBsub && cxix >= 0 &&
1459 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1463 cxix = dopoptosub_at(ccstack, cxix - 1);
1466 cx = &ccstack[cxix];
1467 if (CxTYPE(cx) == CXt_SUB) {
1468 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1469 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1470 field below is defined for any cx. */
1471 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1472 cx = &ccstack[dbcxix];
1475 if (GIMME != G_ARRAY) {
1476 hv = cx->blk_oldcop->cop_stash;
1478 PUSHs(&PL_sv_undef);
1481 sv_setpv(TARG, HvNAME(hv));
1487 hv = cx->blk_oldcop->cop_stash;
1489 PUSHs(&PL_sv_undef);
1491 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1492 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1493 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1496 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1498 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1499 PUSHs(sv_2mortal(sv));
1500 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1503 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1504 PUSHs(sv_2mortal(newSViv(0)));
1506 gimme = (I32)cx->blk_gimme;
1507 if (gimme == G_VOID)
1508 PUSHs(&PL_sv_undef);
1510 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1511 if (CxTYPE(cx) == CXt_EVAL) {
1512 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1513 PUSHs(cx->blk_eval.cur_text);
1516 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1517 /* Require, put the name. */
1518 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1522 else if (CxTYPE(cx) == CXt_SUB &&
1523 cx->blk_sub.hasargs &&
1524 PL_curcop->cop_stash == PL_debstash)
1526 AV *ary = cx->blk_sub.argarray;
1527 int off = AvARRAY(ary) - AvALLOC(ary);
1531 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1534 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1537 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1538 av_extend(PL_dbargs, AvFILLp(ary) + off);
1539 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1540 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1546 sortcv(SV *a, SV *b)
1549 I32 oldsaveix = PL_savestack_ix;
1550 I32 oldscopeix = PL_scopestack_ix;
1552 GvSV(PL_firstgv) = a;
1553 GvSV(PL_secondgv) = b;
1554 PL_stack_sp = PL_stack_base;
1557 if (PL_stack_sp != PL_stack_base + 1)
1558 croak("Sort subroutine didn't return single value");
1559 if (!SvNIOKp(*PL_stack_sp))
1560 croak("Sort subroutine didn't return a numeric value");
1561 result = SvIV(*PL_stack_sp);
1562 while (PL_scopestack_ix > oldscopeix) {
1565 leave_scope(oldsaveix);
1579 sv_reset(tmps, PL_curcop->cop_stash);
1591 PL_curcop = (COP*)PL_op;
1592 TAINT_NOT; /* Each statement is presumed innocent */
1593 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1596 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1600 register PERL_CONTEXT *cx;
1601 I32 gimme = G_ARRAY;
1608 DIE("No DB::DB routine defined");
1610 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1622 push_return(PL_op->op_next);
1623 PUSHBLOCK(cx, CXt_SUB, SP);
1626 (void)SvREFCNT_inc(cv);
1627 SAVESPTR(PL_curpad);
1628 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1629 RETURNOP(CvSTART(cv));
1643 register PERL_CONTEXT *cx;
1644 I32 gimme = GIMME_V;
1651 if (PL_op->op_flags & OPf_SPECIAL) {
1653 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1654 SAVEGENERICSV(*svp);
1658 #endif /* USE_THREADS */
1659 if (PL_op->op_targ) {
1660 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1664 svp = &GvSV((GV*)POPs); /* symbol table variable */
1665 SAVEGENERICSV(*svp);
1671 PUSHBLOCK(cx, CXt_LOOP, SP);
1672 PUSHLOOP(cx, svp, MARK);
1673 if (PL_op->op_flags & OPf_STACKED) {
1674 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1675 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1677 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1678 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1679 if (SvNV(sv) < IV_MIN ||
1680 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1681 croak("Range iterator outside integer range");
1682 cx->blk_loop.iterix = SvIV(sv);
1683 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1686 cx->blk_loop.iterlval = newSVsv(sv);
1690 cx->blk_loop.iterary = PL_curstack;
1691 AvFILLp(PL_curstack) = SP - PL_stack_base;
1692 cx->blk_loop.iterix = MARK - PL_stack_base;
1701 register PERL_CONTEXT *cx;
1702 I32 gimme = GIMME_V;
1708 PUSHBLOCK(cx, CXt_LOOP, SP);
1709 PUSHLOOP(cx, 0, SP);
1717 register PERL_CONTEXT *cx;
1718 struct block_loop cxloop;
1726 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1729 if (gimme == G_VOID)
1731 else if (gimme == G_SCALAR) {
1733 *++newsp = sv_mortalcopy(*SP);
1735 *++newsp = &PL_sv_undef;
1739 *++newsp = sv_mortalcopy(*++mark);
1740 TAINT_NOT; /* Each item is independent */
1746 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1747 PL_curpm = newpm; /* ... and pop $1 et al */
1759 register PERL_CONTEXT *cx;
1760 struct block_sub cxsub;
1761 bool popsub2 = FALSE;
1767 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1768 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1769 if (cxstack_ix > PL_sortcxix)
1770 dounwind(PL_sortcxix);
1771 AvARRAY(PL_curstack)[1] = *SP;
1772 PL_stack_sp = PL_stack_base + 1;
1777 cxix = dopoptosub(cxstack_ix);
1779 DIE("Can't return outside a subroutine");
1780 if (cxix < cxstack_ix)
1784 switch (CxTYPE(cx)) {
1786 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1791 if (optype == OP_REQUIRE &&
1792 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1794 /* Unassume the success we assumed earlier. */
1795 char *name = cx->blk_eval.old_name;
1796 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1797 DIE("%s did not return a true value", name);
1801 DIE("panic: return");
1805 if (gimme == G_SCALAR) {
1808 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1810 *++newsp = SvREFCNT_inc(*SP);
1815 *++newsp = sv_mortalcopy(*SP);
1818 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1820 *++newsp = sv_mortalcopy(*SP);
1822 *++newsp = &PL_sv_undef;
1824 else if (gimme == G_ARRAY) {
1825 while (++MARK <= SP) {
1826 *++newsp = (popsub2 && SvTEMP(*MARK))
1827 ? *MARK : sv_mortalcopy(*MARK);
1828 TAINT_NOT; /* Each item is independent */
1831 PL_stack_sp = newsp;
1833 /* Stack values are safe: */
1835 POPSUB2(); /* release CV and @_ ... */
1837 PL_curpm = newpm; /* ... and pop $1 et al */
1840 return pop_return();
1847 register PERL_CONTEXT *cx;
1848 struct block_loop cxloop;
1849 struct block_sub cxsub;
1856 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1858 if (PL_op->op_flags & OPf_SPECIAL) {
1859 cxix = dopoptoloop(cxstack_ix);
1861 DIE("Can't \"last\" outside a block");
1864 cxix = dopoptolabel(cPVOP->op_pv);
1866 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1868 if (cxix < cxstack_ix)
1872 switch (CxTYPE(cx)) {
1874 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1876 nextop = cxloop.last_op->op_next;
1879 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1881 nextop = pop_return();
1885 nextop = pop_return();
1892 if (gimme == G_SCALAR) {
1894 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1895 ? *SP : sv_mortalcopy(*SP);
1897 *++newsp = &PL_sv_undef;
1899 else if (gimme == G_ARRAY) {
1900 while (++MARK <= SP) {
1901 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1902 ? *MARK : sv_mortalcopy(*MARK);
1903 TAINT_NOT; /* Each item is independent */
1909 /* Stack values are safe: */
1912 POPLOOP2(); /* release loop vars ... */
1916 POPSUB2(); /* release CV and @_ ... */
1919 PL_curpm = newpm; /* ... and pop $1 et al */
1928 register PERL_CONTEXT *cx;
1931 if (PL_op->op_flags & OPf_SPECIAL) {
1932 cxix = dopoptoloop(cxstack_ix);
1934 DIE("Can't \"next\" outside a block");
1937 cxix = dopoptolabel(cPVOP->op_pv);
1939 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1941 if (cxix < cxstack_ix)
1945 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1946 LEAVE_SCOPE(oldsave);
1947 return cx->blk_loop.next_op;
1953 register PERL_CONTEXT *cx;
1956 if (PL_op->op_flags & OPf_SPECIAL) {
1957 cxix = dopoptoloop(cxstack_ix);
1959 DIE("Can't \"redo\" outside a block");
1962 cxix = dopoptolabel(cPVOP->op_pv);
1964 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1966 if (cxix < cxstack_ix)
1970 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1971 LEAVE_SCOPE(oldsave);
1972 return cx->blk_loop.redo_op;
1976 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1980 static char too_deep[] = "Target of goto is too deeply nested";
1984 if (o->op_type == OP_LEAVE ||
1985 o->op_type == OP_SCOPE ||
1986 o->op_type == OP_LEAVELOOP ||
1987 o->op_type == OP_LEAVETRY)
1989 *ops++ = cUNOPo->op_first;
1994 if (o->op_flags & OPf_KIDS) {
1996 /* First try all the kids at this level, since that's likeliest. */
1997 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1998 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1999 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2002 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2003 if (kid == PL_lastgotoprobe)
2005 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2007 (ops[-1]->op_type != OP_NEXTSTATE &&
2008 ops[-1]->op_type != OP_DBSTATE)))
2010 if (o = dofindlabel(kid, label, ops, oplimit))
2020 return pp_goto(ARGS);
2029 register PERL_CONTEXT *cx;
2030 #define GOTO_DEPTH 64
2031 OP *enterops[GOTO_DEPTH];
2033 int do_dump = (PL_op->op_type == OP_DUMP);
2034 static char must_have_label[] = "goto must have label";
2037 if (PL_op->op_flags & OPf_STACKED) {
2041 /* This egregious kludge implements goto &subroutine */
2042 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2044 register PERL_CONTEXT *cx;
2045 CV* cv = (CV*)SvRV(sv);
2049 int arg_was_real = 0;
2052 if (!CvROOT(cv) && !CvXSUB(cv)) {
2057 /* autoloaded stub? */
2058 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2060 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2061 GvNAMELEN(gv), FALSE);
2062 if (autogv && (cv = GvCV(autogv)))
2064 tmpstr = sv_newmortal();
2065 gv_efullname3(tmpstr, gv, Nullch);
2066 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2068 DIE("Goto undefined subroutine");
2071 /* First do some returnish stuff. */
2072 cxix = dopoptosub(cxstack_ix);
2074 DIE("Can't goto subroutine outside a subroutine");
2075 if (cxix < cxstack_ix)
2078 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2079 DIE("Can't goto subroutine from an eval-string");
2081 if (CxTYPE(cx) == CXt_SUB &&
2082 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2083 AV* av = cx->blk_sub.argarray;
2085 items = AvFILLp(av) + 1;
2087 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2088 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2089 PL_stack_sp += items;
2091 SvREFCNT_dec(GvAV(PL_defgv));
2092 GvAV(PL_defgv) = cx->blk_sub.savearray;
2093 #endif /* USE_THREADS */
2096 AvREAL_off(av); /* so av_clear() won't clobber elts */
2100 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2104 av = (AV*)PL_curpad[0];
2106 av = GvAV(PL_defgv);
2108 items = AvFILLp(av) + 1;
2110 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2111 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2112 PL_stack_sp += items;
2114 if (CxTYPE(cx) == CXt_SUB &&
2115 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2116 SvREFCNT_dec(cx->blk_sub.cv);
2117 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2118 LEAVE_SCOPE(oldsave);
2120 /* Now do some callish stuff. */
2123 if (CvOLDSTYLE(cv)) {
2124 I32 (*fp3)_((int,int,int));
2129 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2130 items = (*fp3)(CvXSUBANY(cv).any_i32,
2131 mark - PL_stack_base + 1,
2133 SP = PL_stack_base + items;
2139 PL_stack_sp--; /* There is no cv arg. */
2140 /* Push a mark for the start of arglist */
2142 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2143 /* Pop the current context like a decent sub should */
2144 POPBLOCK(cx, PL_curpm);
2145 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2148 return pop_return();
2151 AV* padlist = CvPADLIST(cv);
2152 SV** svp = AvARRAY(padlist);
2153 if (CxTYPE(cx) == CXt_EVAL) {
2154 PL_in_eval = cx->blk_eval.old_in_eval;
2155 PL_eval_root = cx->blk_eval.old_eval_root;
2156 cx->cx_type = CXt_SUB;
2157 cx->blk_sub.hasargs = 0;
2159 cx->blk_sub.cv = cv;
2160 cx->blk_sub.olddepth = CvDEPTH(cv);
2162 if (CvDEPTH(cv) < 2)
2163 (void)SvREFCNT_inc(cv);
2164 else { /* save temporaries on recursion? */
2165 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2166 sub_crush_depth(cv);
2167 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2168 AV *newpad = newAV();
2169 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2170 I32 ix = AvFILLp((AV*)svp[1]);
2171 svp = AvARRAY(svp[0]);
2172 for ( ;ix > 0; ix--) {
2173 if (svp[ix] != &PL_sv_undef) {
2174 char *name = SvPVX(svp[ix]);
2175 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2178 /* outer lexical or anon code */
2179 av_store(newpad, ix,
2180 SvREFCNT_inc(oldpad[ix]) );
2182 else { /* our own lexical */
2184 av_store(newpad, ix, sv = (SV*)newAV());
2185 else if (*name == '%')
2186 av_store(newpad, ix, sv = (SV*)newHV());
2188 av_store(newpad, ix, sv = NEWSV(0,0));
2193 av_store(newpad, ix, sv = NEWSV(0,0));
2197 if (cx->blk_sub.hasargs) {
2200 av_store(newpad, 0, (SV*)av);
2201 AvFLAGS(av) = AVf_REIFY;
2203 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2204 AvFILLp(padlist) = CvDEPTH(cv);
2205 svp = AvARRAY(padlist);
2209 if (!cx->blk_sub.hasargs) {
2210 AV* av = (AV*)PL_curpad[0];
2212 items = AvFILLp(av) + 1;
2214 /* Mark is at the end of the stack. */
2216 Copy(AvARRAY(av), SP + 1, items, SV*);
2221 #endif /* USE_THREADS */
2222 SAVESPTR(PL_curpad);
2223 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2225 if (cx->blk_sub.hasargs)
2226 #endif /* USE_THREADS */
2228 AV* av = (AV*)PL_curpad[0];
2232 cx->blk_sub.savearray = GvAV(PL_defgv);
2233 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2234 #endif /* USE_THREADS */
2235 cx->blk_sub.argarray = av;
2238 if (items >= AvMAX(av) + 1) {
2240 if (AvARRAY(av) != ary) {
2241 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2242 SvPVX(av) = (char*)ary;
2244 if (items >= AvMAX(av) + 1) {
2245 AvMAX(av) = items - 1;
2246 Renew(ary,items+1,SV*);
2248 SvPVX(av) = (char*)ary;
2251 Copy(mark,AvARRAY(av),items,SV*);
2252 AvFILLp(av) = items - 1;
2253 /* preserve @_ nature */
2264 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2266 * We do not care about using sv to call CV;
2267 * it's for informational purposes only.
2269 SV *sv = GvSV(PL_DBsub);
2272 if (PERLDB_SUB_NN) {
2273 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2276 gv_efullname3(sv, CvGV(cv), Nullch);
2279 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2280 PUSHMARK( PL_stack_sp );
2281 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2285 RETURNOP(CvSTART(cv));
2289 label = SvPV(sv,n_a);
2290 if (!(do_dump || *label))
2291 DIE(must_have_label);
2294 else if (PL_op->op_flags & OPf_SPECIAL) {
2296 DIE(must_have_label);
2299 label = cPVOP->op_pv;
2301 if (label && *label) {
2306 PL_lastgotoprobe = 0;
2308 for (ix = cxstack_ix; ix >= 0; ix--) {
2310 switch (CxTYPE(cx)) {
2312 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2315 gotoprobe = cx->blk_oldcop->op_sibling;
2321 gotoprobe = cx->blk_oldcop->op_sibling;
2323 gotoprobe = PL_main_root;
2326 if (CvDEPTH(cx->blk_sub.cv)) {
2327 gotoprobe = CvROOT(cx->blk_sub.cv);
2332 DIE("Can't \"goto\" outside a block");
2336 gotoprobe = PL_main_root;
2339 retop = dofindlabel(gotoprobe, label,
2340 enterops, enterops + GOTO_DEPTH);
2343 PL_lastgotoprobe = gotoprobe;
2346 DIE("Can't find label %s", label);
2348 /* pop unwanted frames */
2350 if (ix < cxstack_ix) {
2357 oldsave = PL_scopestack[PL_scopestack_ix];
2358 LEAVE_SCOPE(oldsave);
2361 /* push wanted frames */
2363 if (*enterops && enterops[1]) {
2365 for (ix = 1; enterops[ix]; ix++) {
2366 PL_op = enterops[ix];
2367 /* Eventually we may want to stack the needed arguments
2368 * for each op. For now, we punt on the hard ones. */
2369 if (PL_op->op_type == OP_ENTERITER)
2370 DIE("Can't \"goto\" into the middle of a foreach loop",
2372 (CALLOP->op_ppaddr)(ARGS);
2380 if (!retop) retop = PL_main_start;
2382 PL_restartop = retop;
2383 PL_do_undump = TRUE;
2387 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2388 PL_do_undump = FALSE;
2404 if (anum == 1 && VMSISH_EXIT)
2409 PUSHs(&PL_sv_undef);
2417 double value = SvNVx(GvSV(cCOP->cop_gv));
2418 register I32 match = I_32(value);
2421 if (((double)match) > value)
2422 --match; /* was fractional--truncate other way */
2424 match -= cCOP->uop.scop.scop_offset;
2427 else if (match > cCOP->uop.scop.scop_max)
2428 match = cCOP->uop.scop.scop_max;
2429 PL_op = cCOP->uop.scop.scop_next[match];
2439 PL_op = PL_op->op_next; /* can't assume anything */
2442 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2443 match -= cCOP->uop.scop.scop_offset;
2446 else if (match > cCOP->uop.scop.scop_max)
2447 match = cCOP->uop.scop.scop_max;
2448 PL_op = cCOP->uop.scop.scop_next[match];
2457 save_lines(AV *array, SV *sv)
2459 register char *s = SvPVX(sv);
2460 register char *send = SvPVX(sv) + SvCUR(sv);
2462 register I32 line = 1;
2464 while (s && s < send) {
2465 SV *tmpstr = NEWSV(85,0);
2467 sv_upgrade(tmpstr, SVt_PVMG);
2468 t = strchr(s, '\n');
2474 sv_setpvn(tmpstr, s, t - s);
2475 av_store(array, line++, tmpstr);
2490 assert(CATCH_GET == TRUE);
2491 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2495 default: /* topmost level handles it */
2504 PL_op = PL_restartop;
2517 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2518 /* sv Text to convert to OP tree. */
2519 /* startop op_free() this to undo. */
2520 /* code Short string id of the caller. */
2522 dSP; /* Make POPBLOCK work. */
2525 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2528 OP *oop = PL_op, *rop;
2529 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2535 /* switch to eval mode */
2537 if (PL_curcop == &PL_compiling) {
2538 SAVESPTR(PL_compiling.cop_stash);
2539 PL_compiling.cop_stash = PL_curstash;
2541 SAVESPTR(PL_compiling.cop_filegv);
2542 SAVEI16(PL_compiling.cop_line);
2543 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2544 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2545 PL_compiling.cop_line = 1;
2546 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2547 deleting the eval's FILEGV from the stash before gv_check() runs
2548 (i.e. before run-time proper). To work around the coredump that
2549 ensues, we always turn GvMULTI_on for any globals that were
2550 introduced within evals. See force_ident(). GSAR 96-10-12 */
2551 safestr = savepv(tmpbuf);
2552 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2554 #ifdef OP_IN_REGISTER
2562 PL_op->op_type = OP_ENTEREVAL;
2563 PL_op->op_flags = 0; /* Avoid uninit warning. */
2564 PUSHBLOCK(cx, CXt_EVAL, SP);
2565 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2566 rop = doeval(G_SCALAR, startop);
2567 POPBLOCK(cx,PL_curpm);
2570 (*startop)->op_type = OP_NULL;
2571 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2573 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2575 if (PL_curcop == &PL_compiling)
2576 PL_compiling.op_private = PL_hints;
2577 #ifdef OP_IN_REGISTER
2583 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2585 doeval(int gimme, OP** startop)
2598 /* set up a scratch pad */
2601 SAVESPTR(PL_curpad);
2602 SAVESPTR(PL_comppad);
2603 SAVESPTR(PL_comppad_name);
2604 SAVEI32(PL_comppad_name_fill);
2605 SAVEI32(PL_min_intro_pending);
2606 SAVEI32(PL_max_intro_pending);
2609 for (i = cxstack_ix - 1; i >= 0; i--) {
2610 PERL_CONTEXT *cx = &cxstack[i];
2611 if (CxTYPE(cx) == CXt_EVAL)
2613 else if (CxTYPE(cx) == CXt_SUB) {
2614 caller = cx->blk_sub.cv;
2619 SAVESPTR(PL_compcv);
2620 PL_compcv = (CV*)NEWSV(1104,0);
2621 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2622 CvUNIQUE_on(PL_compcv);
2624 CvOWNER(PL_compcv) = 0;
2625 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2626 MUTEX_INIT(CvMUTEXP(PL_compcv));
2627 #endif /* USE_THREADS */
2629 PL_comppad = newAV();
2630 av_push(PL_comppad, Nullsv);
2631 PL_curpad = AvARRAY(PL_comppad);
2632 PL_comppad_name = newAV();
2633 PL_comppad_name_fill = 0;
2634 PL_min_intro_pending = 0;
2637 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2638 PL_curpad[0] = (SV*)newAV();
2639 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2640 #endif /* USE_THREADS */
2642 comppadlist = newAV();
2643 AvREAL_off(comppadlist);
2644 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2645 av_store(comppadlist, 1, (SV*)PL_comppad);
2646 CvPADLIST(PL_compcv) = comppadlist;
2648 if (!saveop || saveop->op_type != OP_REQUIRE)
2649 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2651 SAVEFREESV(PL_compcv);
2653 /* make sure we compile in the right package */
2655 newstash = PL_curcop->cop_stash;
2656 if (PL_curstash != newstash) {
2657 SAVESPTR(PL_curstash);
2658 PL_curstash = newstash;
2660 SAVESPTR(PL_beginav);
2661 PL_beginav = newAV();
2662 SAVEFREESV(PL_beginav);
2664 /* try to compile it */
2666 PL_eval_root = Nullop;
2668 PL_curcop = &PL_compiling;
2669 PL_curcop->cop_arybase = 0;
2670 SvREFCNT_dec(PL_rs);
2671 PL_rs = newSVpv("\n", 1);
2672 if (saveop && saveop->op_flags & OPf_SPECIAL)
2676 if (yyparse() || PL_error_count || !PL_eval_root) {
2680 I32 optype = 0; /* Might be reset by POPEVAL. */
2685 op_free(PL_eval_root);
2686 PL_eval_root = Nullop;
2688 SP = PL_stack_base + POPMARK; /* pop original mark */
2690 POPBLOCK(cx,PL_curpm);
2696 if (optype == OP_REQUIRE) {
2697 char* msg = SvPVx(ERRSV, n_a);
2698 DIE("%s", *msg ? msg : "Compilation failed in require");
2699 } else if (startop) {
2700 char* msg = SvPVx(ERRSV, n_a);
2702 POPBLOCK(cx,PL_curpm);
2704 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2706 SvREFCNT_dec(PL_rs);
2707 PL_rs = SvREFCNT_inc(PL_nrs);
2709 MUTEX_LOCK(&PL_eval_mutex);
2711 COND_SIGNAL(&PL_eval_cond);
2712 MUTEX_UNLOCK(&PL_eval_mutex);
2713 #endif /* USE_THREADS */
2716 SvREFCNT_dec(PL_rs);
2717 PL_rs = SvREFCNT_inc(PL_nrs);
2718 PL_compiling.cop_line = 0;
2720 *startop = PL_eval_root;
2721 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2722 CvOUTSIDE(PL_compcv) = Nullcv;
2724 SAVEFREEOP(PL_eval_root);
2726 scalarvoid(PL_eval_root);
2727 else if (gimme & G_ARRAY)
2730 scalar(PL_eval_root);
2732 DEBUG_x(dump_eval());
2734 /* Register with debugger: */
2735 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2736 CV *cv = perl_get_cv("DB::postponed", FALSE);
2740 XPUSHs((SV*)PL_compiling.cop_filegv);
2742 perl_call_sv((SV*)cv, G_DISCARD);
2746 /* compiled okay, so do it */
2748 CvDEPTH(PL_compcv) = 1;
2749 SP = PL_stack_base + POPMARK; /* pop original mark */
2750 PL_op = saveop; /* The caller may need it. */
2752 MUTEX_LOCK(&PL_eval_mutex);
2754 COND_SIGNAL(&PL_eval_cond);
2755 MUTEX_UNLOCK(&PL_eval_mutex);
2756 #endif /* USE_THREADS */
2758 RETURNOP(PL_eval_start);
2764 register PERL_CONTEXT *cx;
2769 SV *namesv = Nullsv;
2771 I32 gimme = G_SCALAR;
2772 PerlIO *tryrsfp = 0;
2776 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2777 SET_NUMERIC_STANDARD();
2778 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2779 DIE("Perl %s required--this is only version %s, stopped",
2780 SvPV(sv,n_a),PL_patchlevel);
2783 name = SvPV(sv, len);
2784 if (!(name && len > 0 && *name))
2785 DIE("Null filename used");
2786 TAINT_PROPER("require");
2787 if (PL_op->op_type == OP_REQUIRE &&
2788 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2789 *svp != &PL_sv_undef)
2792 /* prepare to compile file */
2797 (name[1] == '.' && name[2] == '/')))
2799 || (name[0] && name[1] == ':')
2802 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2805 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2806 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2811 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2814 AV *ar = GvAVn(PL_incgv);
2818 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2821 namesv = NEWSV(806, 0);
2822 for (i = 0; i <= AvFILL(ar); i++) {
2823 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2826 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2828 sv_setpv(namesv, unixdir);
2829 sv_catpv(namesv, unixname);
2831 sv_setpvf(namesv, "%s/%s", dir, name);
2833 TAINT_PROPER("require");
2834 tryname = SvPVX(namesv);
2835 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2837 if (tryname[0] == '.' && tryname[1] == '/')
2844 SAVESPTR(PL_compiling.cop_filegv);
2845 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2846 SvREFCNT_dec(namesv);
2848 if (PL_op->op_type == OP_REQUIRE) {
2849 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2850 SV *dirmsgsv = NEWSV(0, 0);
2851 AV *ar = GvAVn(PL_incgv);
2853 if (instr(SvPVX(msg), ".h "))
2854 sv_catpv(msg, " (change .h to .ph maybe?)");
2855 if (instr(SvPVX(msg), ".ph "))
2856 sv_catpv(msg, " (did you run h2ph?)");
2857 sv_catpv(msg, " (@INC contains:");
2858 for (i = 0; i <= AvFILL(ar); i++) {
2859 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2860 sv_setpvf(dirmsgsv, " %s", dir);
2861 sv_catsv(msg, dirmsgsv);
2863 sv_catpvn(msg, ")", 1);
2864 SvREFCNT_dec(dirmsgsv);
2871 SETERRNO(0, SS$_NORMAL);
2873 /* Assume success here to prevent recursive requirement. */
2874 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2875 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2879 lex_start(sv_2mortal(newSVpv("",0)));
2880 SAVEGENERICSV(PL_rsfp_filters);
2881 PL_rsfp_filters = Nullav;
2884 name = savepv(name);
2888 SAVEPPTR(PL_compiling.cop_warnings);
2889 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2892 /* switch to eval mode */
2894 push_return(PL_op->op_next);
2895 PUSHBLOCK(cx, CXt_EVAL, SP);
2896 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2898 SAVEI16(PL_compiling.cop_line);
2899 PL_compiling.cop_line = 0;
2903 MUTEX_LOCK(&PL_eval_mutex);
2904 if (PL_eval_owner && PL_eval_owner != thr)
2905 while (PL_eval_owner)
2906 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2907 PL_eval_owner = thr;
2908 MUTEX_UNLOCK(&PL_eval_mutex);
2909 #endif /* USE_THREADS */
2910 return DOCATCH(doeval(G_SCALAR, NULL));
2915 return pp_require(ARGS);
2921 register PERL_CONTEXT *cx;
2923 I32 gimme = GIMME_V, was = PL_sub_generation;
2924 char tmpbuf[TYPE_DIGITS(long) + 12];
2929 if (!SvPV(sv,len) || !len)
2931 TAINT_PROPER("eval");
2937 /* switch to eval mode */
2939 SAVESPTR(PL_compiling.cop_filegv);
2940 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2941 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2942 PL_compiling.cop_line = 1;
2943 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2944 deleting the eval's FILEGV from the stash before gv_check() runs
2945 (i.e. before run-time proper). To work around the coredump that
2946 ensues, we always turn GvMULTI_on for any globals that were
2947 introduced within evals. See force_ident(). GSAR 96-10-12 */
2948 safestr = savepv(tmpbuf);
2949 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2951 PL_hints = PL_op->op_targ;
2952 SAVEPPTR(PL_compiling.cop_warnings);
2953 if (PL_compiling.cop_warnings != WARN_ALL
2954 && PL_compiling.cop_warnings != WARN_NONE){
2955 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2956 SAVEFREESV(PL_compiling.cop_warnings) ;
2959 push_return(PL_op->op_next);
2960 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2961 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2963 /* prepare to compile string */
2965 if (PERLDB_LINE && PL_curstash != PL_debstash)
2966 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2969 MUTEX_LOCK(&PL_eval_mutex);
2970 if (PL_eval_owner && PL_eval_owner != thr)
2971 while (PL_eval_owner)
2972 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2973 PL_eval_owner = thr;
2974 MUTEX_UNLOCK(&PL_eval_mutex);
2975 #endif /* USE_THREADS */
2976 ret = doeval(gimme, NULL);
2977 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2978 && ret != PL_op->op_next) { /* Successive compilation. */
2979 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2981 return DOCATCH(ret);
2991 register PERL_CONTEXT *cx;
2993 U8 save_flags = PL_op -> op_flags;
2998 retop = pop_return();
3001 if (gimme == G_VOID)
3003 else if (gimme == G_SCALAR) {
3006 if (SvFLAGS(TOPs) & SVs_TEMP)
3009 *MARK = sv_mortalcopy(TOPs);
3013 *MARK = &PL_sv_undef;
3017 /* in case LEAVE wipes old return values */
3018 for (mark = newsp + 1; mark <= SP; mark++) {
3019 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3020 *mark = sv_mortalcopy(*mark);
3021 TAINT_NOT; /* Each item is independent */
3025 PL_curpm = newpm; /* Don't pop $1 et al till now */
3028 * Closures mentioned at top level of eval cannot be referenced
3029 * again, and their presence indirectly causes a memory leak.
3030 * (Note that the fact that compcv and friends are still set here
3031 * is, AFAIK, an accident.) --Chip
3033 if (AvFILLp(PL_comppad_name) >= 0) {
3034 SV **svp = AvARRAY(PL_comppad_name);
3036 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3038 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3040 svp[ix] = &PL_sv_undef;
3044 SvREFCNT_dec(CvOUTSIDE(sv));
3045 CvOUTSIDE(sv) = Nullcv;
3058 assert(CvDEPTH(PL_compcv) == 1);
3060 CvDEPTH(PL_compcv) = 0;
3063 if (optype == OP_REQUIRE &&
3064 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3066 /* Unassume the success we assumed earlier. */
3067 char *name = cx->blk_eval.old_name;
3068 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3069 retop = die("%s did not return a true value", name);
3070 /* die_where() did LEAVE, or we won't be here */
3074 if (!(save_flags & OPf_SPECIAL))
3084 register PERL_CONTEXT *cx;
3085 I32 gimme = GIMME_V;
3090 push_return(cLOGOP->op_other->op_next);
3091 PUSHBLOCK(cx, CXt_EVAL, SP);
3093 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3098 return DOCATCH(PL_op->op_next);
3108 register PERL_CONTEXT *cx;
3116 if (gimme == G_VOID)
3118 else if (gimme == G_SCALAR) {
3121 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3124 *MARK = sv_mortalcopy(TOPs);
3128 *MARK = &PL_sv_undef;
3133 /* in case LEAVE wipes old return values */
3134 for (mark = newsp + 1; mark <= SP; mark++) {
3135 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3136 *mark = sv_mortalcopy(*mark);
3137 TAINT_NOT; /* Each item is independent */
3141 PL_curpm = newpm; /* Don't pop $1 et al till now */
3152 register char *s = SvPV_force(sv, len);
3153 register char *send = s + len;
3154 register char *base;
3155 register I32 skipspaces = 0;
3158 bool postspace = FALSE;
3166 croak("Null picture in formline");
3168 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3173 *fpc++ = FF_LINEMARK;
3174 noblank = repeat = FALSE;
3192 case ' ': case '\t':
3203 *fpc++ = FF_LITERAL;
3211 *fpc++ = skipspaces;
3215 *fpc++ = FF_NEWLINE;
3219 arg = fpc - linepc + 1;
3226 *fpc++ = FF_LINEMARK;
3227 noblank = repeat = FALSE;
3236 ischop = s[-1] == '^';
3242 arg = (s - base) - 1;
3244 *fpc++ = FF_LITERAL;
3253 *fpc++ = FF_LINEGLOB;
3255 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3256 arg = ischop ? 512 : 0;
3266 arg |= 256 + (s - f);
3268 *fpc++ = s - base; /* fieldsize for FETCH */
3269 *fpc++ = FF_DECIMAL;
3274 bool ismore = FALSE;
3277 while (*++s == '>') ;
3278 prespace = FF_SPACE;
3280 else if (*s == '|') {
3281 while (*++s == '|') ;
3282 prespace = FF_HALFSPACE;
3287 while (*++s == '<') ;
3290 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3294 *fpc++ = s - base; /* fieldsize for FETCH */
3296 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3314 { /* need to jump to the next word */
3316 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3317 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3318 s = SvPVX(sv) + SvCUR(sv) + z;
3320 Copy(fops, s, arg, U16);
3322 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3327 * The rest of this file was derived from source code contributed
3330 * NOTE: this code was derived from Tom Horsley's qsort replacement
3331 * and should not be confused with the original code.
3334 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3336 Permission granted to distribute under the same terms as perl which are
3339 This program is free software; you can redistribute it and/or modify
3340 it under the terms of either:
3342 a) the GNU General Public License as published by the Free
3343 Software Foundation; either version 1, or (at your option) any
3346 b) the "Artistic License" which comes with this Kit.
3348 Details on the perl license can be found in the perl source code which
3349 may be located via the www.perl.com web page.
3351 This is the most wonderfulest possible qsort I can come up with (and
3352 still be mostly portable) My (limited) tests indicate it consistently
3353 does about 20% fewer calls to compare than does the qsort in the Visual
3354 C++ library, other vendors may vary.
3356 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3357 others I invented myself (or more likely re-invented since they seemed
3358 pretty obvious once I watched the algorithm operate for a while).
3360 Most of this code was written while watching the Marlins sweep the Giants
3361 in the 1997 National League Playoffs - no Braves fans allowed to use this
3362 code (just kidding :-).
3364 I realize that if I wanted to be true to the perl tradition, the only
3365 comment in this file would be something like:
3367 ...they shuffled back towards the rear of the line. 'No, not at the
3368 rear!' the slave-driver shouted. 'Three files up. And stay there...
3370 However, I really needed to violate that tradition just so I could keep
3371 track of what happens myself, not to mention some poor fool trying to
3372 understand this years from now :-).
3375 /* ********************************************************** Configuration */
3377 #ifndef QSORT_ORDER_GUESS
3378 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3381 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3382 future processing - a good max upper bound is log base 2 of memory size
3383 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3384 safely be smaller than that since the program is taking up some space and
3385 most operating systems only let you grab some subset of contiguous
3386 memory (not to mention that you are normally sorting data larger than
3387 1 byte element size :-).
3389 #ifndef QSORT_MAX_STACK
3390 #define QSORT_MAX_STACK 32
3393 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3394 Anything bigger and we use qsort. If you make this too small, the qsort
3395 will probably break (or become less efficient), because it doesn't expect
3396 the middle element of a partition to be the same as the right or left -
3397 you have been warned).
3399 #ifndef QSORT_BREAK_EVEN
3400 #define QSORT_BREAK_EVEN 6
3403 /* ************************************************************* Data Types */
3405 /* hold left and right index values of a partition waiting to be sorted (the
3406 partition includes both left and right - right is NOT one past the end or
3407 anything like that).
3409 struct partition_stack_entry {
3412 #ifdef QSORT_ORDER_GUESS
3413 int qsort_break_even;
3417 /* ******************************************************* Shorthand Macros */
3419 /* Note that these macros will be used from inside the qsort function where
3420 we happen to know that the variable 'elt_size' contains the size of an
3421 array element and the variable 'temp' points to enough space to hold a
3422 temp element and the variable 'array' points to the array being sorted
3423 and 'compare' is the pointer to the compare routine.
3425 Also note that there are very many highly architecture specific ways
3426 these might be sped up, but this is simply the most generally portable
3427 code I could think of.
3430 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3433 #define qsort_cmp(elt1, elt2) \
3434 ((this->*compare)(array[elt1], array[elt2]))
3436 #define qsort_cmp(elt1, elt2) \
3437 ((*compare)(array[elt1], array[elt2]))
3440 #ifdef QSORT_ORDER_GUESS
3441 #define QSORT_NOTICE_SWAP swapped++;
3443 #define QSORT_NOTICE_SWAP
3446 /* swaps contents of array elements elt1, elt2.
3448 #define qsort_swap(elt1, elt2) \
3451 temp = array[elt1]; \
3452 array[elt1] = array[elt2]; \
3453 array[elt2] = temp; \
3456 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3457 elt3 and elt3 gets elt1.
3459 #define qsort_rotate(elt1, elt2, elt3) \
3462 temp = array[elt1]; \
3463 array[elt1] = array[elt2]; \
3464 array[elt2] = array[elt3]; \
3465 array[elt3] = temp; \
3468 /* ************************************************************ Debug stuff */
3475 return; /* good place to set a breakpoint */
3478 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3481 doqsort_all_asserts(
3485 int (*compare)(const void * elt1, const void * elt2),
3486 int pc_left, int pc_right, int u_left, int u_right)
3490 qsort_assert(pc_left <= pc_right);
3491 qsort_assert(u_right < pc_left);
3492 qsort_assert(pc_right < u_left);
3493 for (i = u_right + 1; i < pc_left; ++i) {
3494 qsort_assert(qsort_cmp(i, pc_left) < 0);
3496 for (i = pc_left; i < pc_right; ++i) {
3497 qsort_assert(qsort_cmp(i, pc_right) == 0);
3499 for (i = pc_right + 1; i < u_left; ++i) {
3500 qsort_assert(qsort_cmp(pc_right, i) < 0);
3504 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3505 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3506 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3510 #define qsort_assert(t) ((void)0)
3512 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3516 /* ****************************************************************** qsort */
3520 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3525 I32 (*compare)(SV *a, SV *b))
3530 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3531 int next_stack_entry = 0;
3535 #ifdef QSORT_ORDER_GUESS
3536 int qsort_break_even;
3540 /* Make sure we actually have work to do.
3542 if (num_elts <= 1) {
3546 /* Setup the initial partition definition and fall into the sorting loop
3549 part_right = (int)(num_elts - 1);
3550 #ifdef QSORT_ORDER_GUESS
3551 qsort_break_even = QSORT_BREAK_EVEN;
3553 #define qsort_break_even QSORT_BREAK_EVEN
3556 if ((part_right - part_left) >= qsort_break_even) {
3557 /* OK, this is gonna get hairy, so lets try to document all the
3558 concepts and abbreviations and variables and what they keep
3561 pc: pivot chunk - the set of array elements we accumulate in the
3562 middle of the partition, all equal in value to the original
3563 pivot element selected. The pc is defined by:
3565 pc_left - the leftmost array index of the pc
3566 pc_right - the rightmost array index of the pc
3568 we start with pc_left == pc_right and only one element
3569 in the pivot chunk (but it can grow during the scan).
3571 u: uncompared elements - the set of elements in the partition
3572 we have not yet compared to the pivot value. There are two
3573 uncompared sets during the scan - one to the left of the pc
3574 and one to the right.
3576 u_right - the rightmost index of the left side's uncompared set
3577 u_left - the leftmost index of the right side's uncompared set
3579 The leftmost index of the left sides's uncompared set
3580 doesn't need its own variable because it is always defined
3581 by the leftmost edge of the whole partition (part_left). The
3582 same goes for the rightmost edge of the right partition
3585 We know there are no uncompared elements on the left once we
3586 get u_right < part_left and no uncompared elements on the
3587 right once u_left > part_right. When both these conditions
3588 are met, we have completed the scan of the partition.
3590 Any elements which are between the pivot chunk and the
3591 uncompared elements should be less than the pivot value on
3592 the left side and greater than the pivot value on the right
3593 side (in fact, the goal of the whole algorithm is to arrange
3594 for that to be true and make the groups of less-than and
3595 greater-then elements into new partitions to sort again).
3597 As you marvel at the complexity of the code and wonder why it
3598 has to be so confusing. Consider some of the things this level
3599 of confusion brings:
3601 Once I do a compare, I squeeze every ounce of juice out of it. I
3602 never do compare calls I don't have to do, and I certainly never
3605 I also never swap any elements unless I can prove there is a
3606 good reason. Many sort algorithms will swap a known value with
3607 an uncompared value just to get things in the right place (or
3608 avoid complexity :-), but that uncompared value, once it gets
3609 compared, may then have to be swapped again. A lot of the
3610 complexity of this code is due to the fact that it never swaps
3611 anything except compared values, and it only swaps them when the
3612 compare shows they are out of position.
3614 int pc_left, pc_right;
3615 int u_right, u_left;
3619 pc_left = ((part_left + part_right) / 2);
3621 u_right = pc_left - 1;
3622 u_left = pc_right + 1;
3624 /* Qsort works best when the pivot value is also the median value
3625 in the partition (unfortunately you can't find the median value
3626 without first sorting :-), so to give the algorithm a helping
3627 hand, we pick 3 elements and sort them and use the median value
3628 of that tiny set as the pivot value.
3630 Some versions of qsort like to use the left middle and right as
3631 the 3 elements to sort so they can insure the ends of the
3632 partition will contain values which will stop the scan in the
3633 compare loop, but when you have to call an arbitrarily complex
3634 routine to do a compare, its really better to just keep track of
3635 array index values to know when you hit the edge of the
3636 partition and avoid the extra compare. An even better reason to
3637 avoid using a compare call is the fact that you can drop off the
3638 edge of the array if someone foolishly provides you with an
3639 unstable compare function that doesn't always provide consistent
3642 So, since it is simpler for us to compare the three adjacent
3643 elements in the middle of the partition, those are the ones we
3644 pick here (conveniently pointed at by u_right, pc_left, and
3645 u_left). The values of the left, center, and right elements
3646 are refered to as l c and r in the following comments.
3649 #ifdef QSORT_ORDER_GUESS
3652 s = qsort_cmp(u_right, pc_left);
3655 s = qsort_cmp(pc_left, u_left);
3656 /* if l < c, c < r - already in order - nothing to do */
3658 /* l < c, c == r - already in order, pc grows */
3660 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3662 /* l < c, c > r - need to know more */
3663 s = qsort_cmp(u_right, u_left);
3665 /* l < c, c > r, l < r - swap c & r to get ordered */
3666 qsort_swap(pc_left, u_left);
3667 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3668 } else if (s == 0) {
3669 /* l < c, c > r, l == r - swap c&r, grow pc */
3670 qsort_swap(pc_left, u_left);
3672 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3674 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3675 qsort_rotate(pc_left, u_right, u_left);
3676 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3679 } else if (s == 0) {
3681 s = qsort_cmp(pc_left, u_left);
3683 /* l == c, c < r - already in order, grow pc */
3685 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3686 } else if (s == 0) {
3687 /* l == c, c == r - already in order, grow pc both ways */
3690 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3692 /* l == c, c > r - swap l & r, grow pc */
3693 qsort_swap(u_right, u_left);
3695 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3699 s = qsort_cmp(pc_left, u_left);
3701 /* l > c, c < r - need to know more */
3702 s = qsort_cmp(u_right, u_left);
3704 /* l > c, c < r, l < r - swap l & c to get ordered */
3705 qsort_swap(u_right, pc_left);
3706 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3707 } else if (s == 0) {
3708 /* l > c, c < r, l == r - swap l & c, grow pc */
3709 qsort_swap(u_right, pc_left);
3711 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3713 /* l > c, c < r, l > r - rotate lcr into crl to order */
3714 qsort_rotate(u_right, pc_left, u_left);
3715 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3717 } else if (s == 0) {
3718 /* l > c, c == r - swap ends, grow pc */
3719 qsort_swap(u_right, u_left);
3721 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3723 /* l > c, c > r - swap ends to get in order */
3724 qsort_swap(u_right, u_left);
3725 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3728 /* We now know the 3 middle elements have been compared and
3729 arranged in the desired order, so we can shrink the uncompared
3734 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3736 /* The above massive nested if was the simple part :-). We now have
3737 the middle 3 elements ordered and we need to scan through the
3738 uncompared sets on either side, swapping elements that are on
3739 the wrong side or simply shuffling equal elements around to get
3740 all equal elements into the pivot chunk.
3744 int still_work_on_left;
3745 int still_work_on_right;
3747 /* Scan the uncompared values on the left. If I find a value
3748 equal to the pivot value, move it over so it is adjacent to
3749 the pivot chunk and expand the pivot chunk. If I find a value
3750 less than the pivot value, then just leave it - its already
3751 on the correct side of the partition. If I find a greater
3752 value, then stop the scan.
3754 while (still_work_on_left = (u_right >= part_left)) {
3755 s = qsort_cmp(u_right, pc_left);
3758 } else if (s == 0) {
3760 if (pc_left != u_right) {
3761 qsort_swap(u_right, pc_left);
3767 qsort_assert(u_right < pc_left);
3768 qsort_assert(pc_left <= pc_right);
3769 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3770 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3773 /* Do a mirror image scan of uncompared values on the right
3775 while (still_work_on_right = (u_left <= part_right)) {
3776 s = qsort_cmp(pc_right, u_left);
3779 } else if (s == 0) {
3781 if (pc_right != u_left) {
3782 qsort_swap(pc_right, u_left);
3788 qsort_assert(u_left > pc_right);
3789 qsort_assert(pc_left <= pc_right);
3790 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3791 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3794 if (still_work_on_left) {
3795 /* I know I have a value on the left side which needs to be
3796 on the right side, but I need to know more to decide
3797 exactly the best thing to do with it.
3799 if (still_work_on_right) {
3800 /* I know I have values on both side which are out of
3801 position. This is a big win because I kill two birds
3802 with one swap (so to speak). I can advance the
3803 uncompared pointers on both sides after swapping both
3804 of them into the right place.
3806 qsort_swap(u_right, u_left);
3809 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3811 /* I have an out of position value on the left, but the
3812 right is fully scanned, so I "slide" the pivot chunk
3813 and any less-than values left one to make room for the
3814 greater value over on the right. If the out of position
3815 value is immediately adjacent to the pivot chunk (there
3816 are no less-than values), I can do that with a swap,
3817 otherwise, I have to rotate one of the less than values
3818 into the former position of the out of position value
3819 and the right end of the pivot chunk into the left end
3823 if (pc_left == u_right) {
3824 qsort_swap(u_right, pc_right);
3825 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3827 qsort_rotate(u_right, pc_left, pc_right);
3828 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3833 } else if (still_work_on_right) {
3834 /* Mirror image of complex case above: I have an out of
3835 position value on the right, but the left is fully
3836 scanned, so I need to shuffle things around to make room
3837 for the right value on the left.
3840 if (pc_right == u_left) {
3841 qsort_swap(u_left, pc_left);
3842 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3844 qsort_rotate(pc_right, pc_left, u_left);
3845 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3850 /* No more scanning required on either side of partition,
3851 break out of loop and figure out next set of partitions
3857 /* The elements in the pivot chunk are now in the right place. They
3858 will never move or be compared again. All I have to do is decide
3859 what to do with the stuff to the left and right of the pivot
3862 Notes on the QSORT_ORDER_GUESS ifdef code:
3864 1. If I just built these partitions without swapping any (or
3865 very many) elements, there is a chance that the elements are
3866 already ordered properly (being properly ordered will
3867 certainly result in no swapping, but the converse can't be
3870 2. A (properly written) insertion sort will run faster on
3871 already ordered data than qsort will.
3873 3. Perhaps there is some way to make a good guess about
3874 switching to an insertion sort earlier than partition size 6
3875 (for instance - we could save the partition size on the stack
3876 and increase the size each time we find we didn't swap, thus
3877 switching to insertion sort earlier for partitions with a
3878 history of not swapping).
3880 4. Naturally, if I just switch right away, it will make
3881 artificial benchmarks with pure ascending (or descending)
3882 data look really good, but is that a good reason in general?
3886 #ifdef QSORT_ORDER_GUESS
3888 #if QSORT_ORDER_GUESS == 1
3889 qsort_break_even = (part_right - part_left) + 1;
3891 #if QSORT_ORDER_GUESS == 2
3892 qsort_break_even *= 2;
3894 #if QSORT_ORDER_GUESS == 3
3895 int prev_break = qsort_break_even;
3896 qsort_break_even *= qsort_break_even;
3897 if (qsort_break_even < prev_break) {
3898 qsort_break_even = (part_right - part_left) + 1;
3902 qsort_break_even = QSORT_BREAK_EVEN;
3906 if (part_left < pc_left) {
3907 /* There are elements on the left which need more processing.
3908 Check the right as well before deciding what to do.
3910 if (pc_right < part_right) {
3911 /* We have two partitions to be sorted. Stack the biggest one
3912 and process the smallest one on the next iteration. This
3913 minimizes the stack height by insuring that any additional
3914 stack entries must come from the smallest partition which
3915 (because it is smallest) will have the fewest
3916 opportunities to generate additional stack entries.
3918 if ((part_right - pc_right) > (pc_left - part_left)) {
3919 /* stack the right partition, process the left */
3920 partition_stack[next_stack_entry].left = pc_right + 1;
3921 partition_stack[next_stack_entry].right = part_right;
3922 #ifdef QSORT_ORDER_GUESS
3923 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3925 part_right = pc_left - 1;
3927 /* stack the left partition, process the right */
3928 partition_stack[next_stack_entry].left = part_left;
3929 partition_stack[next_stack_entry].right = pc_left - 1;
3930 #ifdef QSORT_ORDER_GUESS
3931 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3933 part_left = pc_right + 1;
3935 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3938 /* The elements on the left are the only remaining elements
3939 that need sorting, arrange for them to be processed as the
3942 part_right = pc_left - 1;
3944 } else if (pc_right < part_right) {
3945 /* There is only one chunk on the right to be sorted, make it
3946 the new partition and loop back around.
3948 part_left = pc_right + 1;
3950 /* This whole partition wound up in the pivot chunk, so
3951 we need to get a new partition off the stack.
3953 if (next_stack_entry == 0) {
3954 /* the stack is empty - we are done */
3958 part_left = partition_stack[next_stack_entry].left;
3959 part_right = partition_stack[next_stack_entry].right;
3960 #ifdef QSORT_ORDER_GUESS
3961 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3965 /* This partition is too small to fool with qsort complexity, just
3966 do an ordinary insertion sort to minimize overhead.
3969 /* Assume 1st element is in right place already, and start checking
3970 at 2nd element to see where it should be inserted.
3972 for (i = part_left + 1; i <= part_right; ++i) {
3974 /* Scan (backwards - just in case 'i' is already in right place)
3975 through the elements already sorted to see if the ith element
3976 belongs ahead of one of them.
3978 for (j = i - 1; j >= part_left; --j) {
3979 if (qsort_cmp(i, j) >= 0) {
3980 /* i belongs right after j
3987 /* Looks like we really need to move some things
3991 for (k = i - 1; k >= j; --k)
3992 array[k + 1] = array[k];
3997 /* That partition is now sorted, grab the next one, or get out
3998 of the loop if there aren't any more.
4001 if (next_stack_entry == 0) {
4002 /* the stack is empty - we are done */
4006 part_left = partition_stack[next_stack_entry].left;
4007 part_right = partition_stack[next_stack_entry].right;
4008 #ifdef QSORT_ORDER_GUESS
4009 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4014 /* Believe it or not, the array is sorted at this point! */