3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
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);
1398 /* SFIO can really mess with your errno */
1401 PerlIO_puts(PerlIO_stderr(), message);
1402 (void)PerlIO_flush(PerlIO_stderr());
1415 if (SvTRUE(left) != SvTRUE(right))
1427 RETURNOP(cLOGOP->op_other);
1436 RETURNOP(cLOGOP->op_other);
1442 register I32 cxix = dopoptosub(cxstack_ix);
1443 register PERL_CONTEXT *cx;
1444 register PERL_CONTEXT *ccstack = cxstack;
1445 PERL_SI *top_si = PL_curstackinfo;
1456 /* we may be in a higher stacklevel, so dig down deeper */
1457 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1458 top_si = top_si->si_prev;
1459 ccstack = top_si->si_cxstack;
1460 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1463 if (GIMME != G_ARRAY)
1467 if (PL_DBsub && cxix >= 0 &&
1468 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1472 cxix = dopoptosub_at(ccstack, cxix - 1);
1475 cx = &ccstack[cxix];
1476 if (CxTYPE(cx) == CXt_SUB) {
1477 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1478 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1479 field below is defined for any cx. */
1480 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1481 cx = &ccstack[dbcxix];
1484 if (GIMME != G_ARRAY) {
1485 hv = cx->blk_oldcop->cop_stash;
1487 PUSHs(&PL_sv_undef);
1490 sv_setpv(TARG, HvNAME(hv));
1496 hv = cx->blk_oldcop->cop_stash;
1498 PUSHs(&PL_sv_undef);
1500 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1501 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1502 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1503 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1506 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1508 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1509 PUSHs(sv_2mortal(sv));
1510 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1513 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1514 PUSHs(sv_2mortal(newSViv(0)));
1516 gimme = (I32)cx->blk_gimme;
1517 if (gimme == G_VOID)
1518 PUSHs(&PL_sv_undef);
1520 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1521 if (CxTYPE(cx) == CXt_EVAL) {
1522 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1523 PUSHs(cx->blk_eval.cur_text);
1526 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1527 /* Require, put the name. */
1528 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1532 else if (CxTYPE(cx) == CXt_SUB &&
1533 cx->blk_sub.hasargs &&
1534 PL_curcop->cop_stash == PL_debstash)
1536 AV *ary = cx->blk_sub.argarray;
1537 int off = AvARRAY(ary) - AvALLOC(ary);
1541 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1544 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1547 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1548 av_extend(PL_dbargs, AvFILLp(ary) + off);
1549 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1550 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1556 sortcv(SV *a, SV *b)
1559 I32 oldsaveix = PL_savestack_ix;
1560 I32 oldscopeix = PL_scopestack_ix;
1562 GvSV(PL_firstgv) = a;
1563 GvSV(PL_secondgv) = b;
1564 PL_stack_sp = PL_stack_base;
1567 if (PL_stack_sp != PL_stack_base + 1)
1568 croak("Sort subroutine didn't return single value");
1569 if (!SvNIOKp(*PL_stack_sp))
1570 croak("Sort subroutine didn't return a numeric value");
1571 result = SvIV(*PL_stack_sp);
1572 while (PL_scopestack_ix > oldscopeix) {
1575 leave_scope(oldsaveix);
1589 sv_reset(tmps, PL_curcop->cop_stash);
1601 PL_curcop = (COP*)PL_op;
1602 TAINT_NOT; /* Each statement is presumed innocent */
1603 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1606 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1610 register PERL_CONTEXT *cx;
1611 I32 gimme = G_ARRAY;
1618 DIE("No DB::DB routine defined");
1620 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1632 push_return(PL_op->op_next);
1633 PUSHBLOCK(cx, CXt_SUB, SP);
1636 (void)SvREFCNT_inc(cv);
1637 SAVESPTR(PL_curpad);
1638 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1639 RETURNOP(CvSTART(cv));
1653 register PERL_CONTEXT *cx;
1654 I32 gimme = GIMME_V;
1661 if (PL_op->op_flags & OPf_SPECIAL) {
1663 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1664 SAVEGENERICSV(*svp);
1668 #endif /* USE_THREADS */
1669 if (PL_op->op_targ) {
1670 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1674 svp = &GvSV((GV*)POPs); /* symbol table variable */
1675 SAVEGENERICSV(*svp);
1681 PUSHBLOCK(cx, CXt_LOOP, SP);
1682 PUSHLOOP(cx, svp, MARK);
1683 if (PL_op->op_flags & OPf_STACKED) {
1684 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1685 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1687 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1688 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1689 if (SvNV(sv) < IV_MIN ||
1690 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1691 croak("Range iterator outside integer range");
1692 cx->blk_loop.iterix = SvIV(sv);
1693 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1696 cx->blk_loop.iterlval = newSVsv(sv);
1700 cx->blk_loop.iterary = PL_curstack;
1701 AvFILLp(PL_curstack) = SP - PL_stack_base;
1702 cx->blk_loop.iterix = MARK - PL_stack_base;
1711 register PERL_CONTEXT *cx;
1712 I32 gimme = GIMME_V;
1718 PUSHBLOCK(cx, CXt_LOOP, SP);
1719 PUSHLOOP(cx, 0, SP);
1727 register PERL_CONTEXT *cx;
1728 struct block_loop cxloop;
1736 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1739 if (gimme == G_VOID)
1741 else if (gimme == G_SCALAR) {
1743 *++newsp = sv_mortalcopy(*SP);
1745 *++newsp = &PL_sv_undef;
1749 *++newsp = sv_mortalcopy(*++mark);
1750 TAINT_NOT; /* Each item is independent */
1756 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1757 PL_curpm = newpm; /* ... and pop $1 et al */
1769 register PERL_CONTEXT *cx;
1770 struct block_sub cxsub;
1771 bool popsub2 = FALSE;
1777 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1778 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1779 if (cxstack_ix > PL_sortcxix)
1780 dounwind(PL_sortcxix);
1781 AvARRAY(PL_curstack)[1] = *SP;
1782 PL_stack_sp = PL_stack_base + 1;
1787 cxix = dopoptosub(cxstack_ix);
1789 DIE("Can't return outside a subroutine");
1790 if (cxix < cxstack_ix)
1794 switch (CxTYPE(cx)) {
1796 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1801 if (optype == OP_REQUIRE &&
1802 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1804 /* Unassume the success we assumed earlier. */
1805 char *name = cx->blk_eval.old_name;
1806 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1807 DIE("%s did not return a true value", name);
1811 DIE("panic: return");
1815 if (gimme == G_SCALAR) {
1818 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1820 *++newsp = SvREFCNT_inc(*SP);
1825 *++newsp = sv_mortalcopy(*SP);
1828 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1830 *++newsp = sv_mortalcopy(*SP);
1832 *++newsp = &PL_sv_undef;
1834 else if (gimme == G_ARRAY) {
1835 while (++MARK <= SP) {
1836 *++newsp = (popsub2 && SvTEMP(*MARK))
1837 ? *MARK : sv_mortalcopy(*MARK);
1838 TAINT_NOT; /* Each item is independent */
1841 PL_stack_sp = newsp;
1843 /* Stack values are safe: */
1845 POPSUB2(); /* release CV and @_ ... */
1847 PL_curpm = newpm; /* ... and pop $1 et al */
1850 return pop_return();
1857 register PERL_CONTEXT *cx;
1858 struct block_loop cxloop;
1859 struct block_sub cxsub;
1866 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1868 if (PL_op->op_flags & OPf_SPECIAL) {
1869 cxix = dopoptoloop(cxstack_ix);
1871 DIE("Can't \"last\" outside a block");
1874 cxix = dopoptolabel(cPVOP->op_pv);
1876 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1878 if (cxix < cxstack_ix)
1882 switch (CxTYPE(cx)) {
1884 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1886 nextop = cxloop.last_op->op_next;
1889 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1891 nextop = pop_return();
1895 nextop = pop_return();
1902 if (gimme == G_SCALAR) {
1904 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1905 ? *SP : sv_mortalcopy(*SP);
1907 *++newsp = &PL_sv_undef;
1909 else if (gimme == G_ARRAY) {
1910 while (++MARK <= SP) {
1911 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1912 ? *MARK : sv_mortalcopy(*MARK);
1913 TAINT_NOT; /* Each item is independent */
1919 /* Stack values are safe: */
1922 POPLOOP2(); /* release loop vars ... */
1926 POPSUB2(); /* release CV and @_ ... */
1929 PL_curpm = newpm; /* ... and pop $1 et al */
1938 register PERL_CONTEXT *cx;
1941 if (PL_op->op_flags & OPf_SPECIAL) {
1942 cxix = dopoptoloop(cxstack_ix);
1944 DIE("Can't \"next\" outside a block");
1947 cxix = dopoptolabel(cPVOP->op_pv);
1949 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1951 if (cxix < cxstack_ix)
1955 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1956 LEAVE_SCOPE(oldsave);
1957 return cx->blk_loop.next_op;
1963 register PERL_CONTEXT *cx;
1966 if (PL_op->op_flags & OPf_SPECIAL) {
1967 cxix = dopoptoloop(cxstack_ix);
1969 DIE("Can't \"redo\" outside a block");
1972 cxix = dopoptolabel(cPVOP->op_pv);
1974 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1976 if (cxix < cxstack_ix)
1980 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1981 LEAVE_SCOPE(oldsave);
1982 return cx->blk_loop.redo_op;
1986 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1990 static char too_deep[] = "Target of goto is too deeply nested";
1994 if (o->op_type == OP_LEAVE ||
1995 o->op_type == OP_SCOPE ||
1996 o->op_type == OP_LEAVELOOP ||
1997 o->op_type == OP_LEAVETRY)
1999 *ops++ = cUNOPo->op_first;
2004 if (o->op_flags & OPf_KIDS) {
2006 /* First try all the kids at this level, since that's likeliest. */
2007 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2008 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2009 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2012 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2013 if (kid == PL_lastgotoprobe)
2015 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2017 (ops[-1]->op_type != OP_NEXTSTATE &&
2018 ops[-1]->op_type != OP_DBSTATE)))
2020 if (o = dofindlabel(kid, label, ops, oplimit))
2030 return pp_goto(ARGS);
2039 register PERL_CONTEXT *cx;
2040 #define GOTO_DEPTH 64
2041 OP *enterops[GOTO_DEPTH];
2043 int do_dump = (PL_op->op_type == OP_DUMP);
2044 static char must_have_label[] = "goto must have label";
2047 if (PL_op->op_flags & OPf_STACKED) {
2051 /* This egregious kludge implements goto &subroutine */
2052 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2054 register PERL_CONTEXT *cx;
2055 CV* cv = (CV*)SvRV(sv);
2059 int arg_was_real = 0;
2062 if (!CvROOT(cv) && !CvXSUB(cv)) {
2067 /* autoloaded stub? */
2068 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2070 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2071 GvNAMELEN(gv), FALSE);
2072 if (autogv && (cv = GvCV(autogv)))
2074 tmpstr = sv_newmortal();
2075 gv_efullname3(tmpstr, gv, Nullch);
2076 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2078 DIE("Goto undefined subroutine");
2081 /* First do some returnish stuff. */
2082 cxix = dopoptosub(cxstack_ix);
2084 DIE("Can't goto subroutine outside a subroutine");
2085 if (cxix < cxstack_ix)
2088 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2089 DIE("Can't goto subroutine from an eval-string");
2091 if (CxTYPE(cx) == CXt_SUB &&
2092 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2093 AV* av = cx->blk_sub.argarray;
2095 items = AvFILLp(av) + 1;
2097 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2098 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2099 PL_stack_sp += items;
2101 SvREFCNT_dec(GvAV(PL_defgv));
2102 GvAV(PL_defgv) = cx->blk_sub.savearray;
2103 #endif /* USE_THREADS */
2106 AvREAL_off(av); /* so av_clear() won't clobber elts */
2110 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2114 av = (AV*)PL_curpad[0];
2116 av = GvAV(PL_defgv);
2118 items = AvFILLp(av) + 1;
2120 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2121 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2122 PL_stack_sp += items;
2124 if (CxTYPE(cx) == CXt_SUB &&
2125 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2126 SvREFCNT_dec(cx->blk_sub.cv);
2127 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2128 LEAVE_SCOPE(oldsave);
2130 /* Now do some callish stuff. */
2133 #ifdef PERL_XSUB_OLDSTYLE
2134 if (CvOLDSTYLE(cv)) {
2135 I32 (*fp3)_((int,int,int));
2140 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2141 items = (*fp3)(CvXSUBANY(cv).any_i32,
2142 mark - PL_stack_base + 1,
2144 SP = PL_stack_base + items;
2147 #endif /* PERL_XSUB_OLDSTYLE */
2152 PL_stack_sp--; /* There is no cv arg. */
2153 /* Push a mark for the start of arglist */
2155 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2156 /* Pop the current context like a decent sub should */
2157 POPBLOCK(cx, PL_curpm);
2158 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2161 return pop_return();
2164 AV* padlist = CvPADLIST(cv);
2165 SV** svp = AvARRAY(padlist);
2166 if (CxTYPE(cx) == CXt_EVAL) {
2167 PL_in_eval = cx->blk_eval.old_in_eval;
2168 PL_eval_root = cx->blk_eval.old_eval_root;
2169 cx->cx_type = CXt_SUB;
2170 cx->blk_sub.hasargs = 0;
2172 cx->blk_sub.cv = cv;
2173 cx->blk_sub.olddepth = CvDEPTH(cv);
2175 if (CvDEPTH(cv) < 2)
2176 (void)SvREFCNT_inc(cv);
2177 else { /* save temporaries on recursion? */
2178 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2179 sub_crush_depth(cv);
2180 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2181 AV *newpad = newAV();
2182 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2183 I32 ix = AvFILLp((AV*)svp[1]);
2184 svp = AvARRAY(svp[0]);
2185 for ( ;ix > 0; ix--) {
2186 if (svp[ix] != &PL_sv_undef) {
2187 char *name = SvPVX(svp[ix]);
2188 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2191 /* outer lexical or anon code */
2192 av_store(newpad, ix,
2193 SvREFCNT_inc(oldpad[ix]) );
2195 else { /* our own lexical */
2197 av_store(newpad, ix, sv = (SV*)newAV());
2198 else if (*name == '%')
2199 av_store(newpad, ix, sv = (SV*)newHV());
2201 av_store(newpad, ix, sv = NEWSV(0,0));
2206 av_store(newpad, ix, sv = NEWSV(0,0));
2210 if (cx->blk_sub.hasargs) {
2213 av_store(newpad, 0, (SV*)av);
2214 AvFLAGS(av) = AVf_REIFY;
2216 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2217 AvFILLp(padlist) = CvDEPTH(cv);
2218 svp = AvARRAY(padlist);
2222 if (!cx->blk_sub.hasargs) {
2223 AV* av = (AV*)PL_curpad[0];
2225 items = AvFILLp(av) + 1;
2227 /* Mark is at the end of the stack. */
2229 Copy(AvARRAY(av), SP + 1, items, SV*);
2234 #endif /* USE_THREADS */
2235 SAVESPTR(PL_curpad);
2236 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2238 if (cx->blk_sub.hasargs)
2239 #endif /* USE_THREADS */
2241 AV* av = (AV*)PL_curpad[0];
2245 cx->blk_sub.savearray = GvAV(PL_defgv);
2246 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2247 #endif /* USE_THREADS */
2248 cx->blk_sub.argarray = av;
2251 if (items >= AvMAX(av) + 1) {
2253 if (AvARRAY(av) != ary) {
2254 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2255 SvPVX(av) = (char*)ary;
2257 if (items >= AvMAX(av) + 1) {
2258 AvMAX(av) = items - 1;
2259 Renew(ary,items+1,SV*);
2261 SvPVX(av) = (char*)ary;
2264 Copy(mark,AvARRAY(av),items,SV*);
2265 AvFILLp(av) = items - 1;
2266 /* preserve @_ nature */
2277 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2279 * We do not care about using sv to call CV;
2280 * it's for informational purposes only.
2282 SV *sv = GvSV(PL_DBsub);
2285 if (PERLDB_SUB_NN) {
2286 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2289 gv_efullname3(sv, CvGV(cv), Nullch);
2292 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2293 PUSHMARK( PL_stack_sp );
2294 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2298 RETURNOP(CvSTART(cv));
2302 label = SvPV(sv,n_a);
2303 if (!(do_dump || *label))
2304 DIE(must_have_label);
2307 else if (PL_op->op_flags & OPf_SPECIAL) {
2309 DIE(must_have_label);
2312 label = cPVOP->op_pv;
2314 if (label && *label) {
2319 PL_lastgotoprobe = 0;
2321 for (ix = cxstack_ix; ix >= 0; ix--) {
2323 switch (CxTYPE(cx)) {
2325 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2328 gotoprobe = cx->blk_oldcop->op_sibling;
2334 gotoprobe = cx->blk_oldcop->op_sibling;
2336 gotoprobe = PL_main_root;
2339 if (CvDEPTH(cx->blk_sub.cv)) {
2340 gotoprobe = CvROOT(cx->blk_sub.cv);
2345 DIE("Can't \"goto\" outside a block");
2349 gotoprobe = PL_main_root;
2352 retop = dofindlabel(gotoprobe, label,
2353 enterops, enterops + GOTO_DEPTH);
2356 PL_lastgotoprobe = gotoprobe;
2359 DIE("Can't find label %s", label);
2361 /* pop unwanted frames */
2363 if (ix < cxstack_ix) {
2370 oldsave = PL_scopestack[PL_scopestack_ix];
2371 LEAVE_SCOPE(oldsave);
2374 /* push wanted frames */
2376 if (*enterops && enterops[1]) {
2378 for (ix = 1; enterops[ix]; ix++) {
2379 PL_op = enterops[ix];
2380 /* Eventually we may want to stack the needed arguments
2381 * for each op. For now, we punt on the hard ones. */
2382 if (PL_op->op_type == OP_ENTERITER)
2383 DIE("Can't \"goto\" into the middle of a foreach loop",
2385 (CALLOP->op_ppaddr)(ARGS);
2393 if (!retop) retop = PL_main_start;
2395 PL_restartop = retop;
2396 PL_do_undump = TRUE;
2400 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2401 PL_do_undump = FALSE;
2417 if (anum == 1 && VMSISH_EXIT)
2422 PUSHs(&PL_sv_undef);
2430 double value = SvNVx(GvSV(cCOP->cop_gv));
2431 register I32 match = I_32(value);
2434 if (((double)match) > value)
2435 --match; /* was fractional--truncate other way */
2437 match -= cCOP->uop.scop.scop_offset;
2440 else if (match > cCOP->uop.scop.scop_max)
2441 match = cCOP->uop.scop.scop_max;
2442 PL_op = cCOP->uop.scop.scop_next[match];
2452 PL_op = PL_op->op_next; /* can't assume anything */
2455 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2456 match -= cCOP->uop.scop.scop_offset;
2459 else if (match > cCOP->uop.scop.scop_max)
2460 match = cCOP->uop.scop.scop_max;
2461 PL_op = cCOP->uop.scop.scop_next[match];
2470 save_lines(AV *array, SV *sv)
2472 register char *s = SvPVX(sv);
2473 register char *send = SvPVX(sv) + SvCUR(sv);
2475 register I32 line = 1;
2477 while (s && s < send) {
2478 SV *tmpstr = NEWSV(85,0);
2480 sv_upgrade(tmpstr, SVt_PVMG);
2481 t = strchr(s, '\n');
2487 sv_setpvn(tmpstr, s, t - s);
2488 av_store(array, line++, tmpstr);
2503 assert(CATCH_GET == TRUE);
2504 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2508 default: /* topmost level handles it */
2517 PL_op = PL_restartop;
2530 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2531 /* sv Text to convert to OP tree. */
2532 /* startop op_free() this to undo. */
2533 /* code Short string id of the caller. */
2535 dSP; /* Make POPBLOCK work. */
2538 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2541 OP *oop = PL_op, *rop;
2542 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2548 /* switch to eval mode */
2550 if (PL_curcop == &PL_compiling) {
2551 SAVESPTR(PL_compiling.cop_stash);
2552 PL_compiling.cop_stash = PL_curstash;
2554 SAVESPTR(PL_compiling.cop_filegv);
2555 SAVEI16(PL_compiling.cop_line);
2556 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2557 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2558 PL_compiling.cop_line = 1;
2559 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2560 deleting the eval's FILEGV from the stash before gv_check() runs
2561 (i.e. before run-time proper). To work around the coredump that
2562 ensues, we always turn GvMULTI_on for any globals that were
2563 introduced within evals. See force_ident(). GSAR 96-10-12 */
2564 safestr = savepv(tmpbuf);
2565 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2567 #ifdef OP_IN_REGISTER
2575 PL_op->op_type = OP_ENTEREVAL;
2576 PL_op->op_flags = 0; /* Avoid uninit warning. */
2577 PUSHBLOCK(cx, CXt_EVAL, SP);
2578 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2579 rop = doeval(G_SCALAR, startop);
2580 POPBLOCK(cx,PL_curpm);
2583 (*startop)->op_type = OP_NULL;
2584 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2586 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2588 if (PL_curcop == &PL_compiling)
2589 PL_compiling.op_private = PL_hints;
2590 #ifdef OP_IN_REGISTER
2596 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2598 doeval(int gimme, OP** startop)
2611 /* set up a scratch pad */
2614 SAVESPTR(PL_curpad);
2615 SAVESPTR(PL_comppad);
2616 SAVESPTR(PL_comppad_name);
2617 SAVEI32(PL_comppad_name_fill);
2618 SAVEI32(PL_min_intro_pending);
2619 SAVEI32(PL_max_intro_pending);
2622 for (i = cxstack_ix - 1; i >= 0; i--) {
2623 PERL_CONTEXT *cx = &cxstack[i];
2624 if (CxTYPE(cx) == CXt_EVAL)
2626 else if (CxTYPE(cx) == CXt_SUB) {
2627 caller = cx->blk_sub.cv;
2632 SAVESPTR(PL_compcv);
2633 PL_compcv = (CV*)NEWSV(1104,0);
2634 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2635 CvEVAL_on(PL_compcv);
2637 CvOWNER(PL_compcv) = 0;
2638 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2639 MUTEX_INIT(CvMUTEXP(PL_compcv));
2640 #endif /* USE_THREADS */
2642 PL_comppad = newAV();
2643 av_push(PL_comppad, Nullsv);
2644 PL_curpad = AvARRAY(PL_comppad);
2645 PL_comppad_name = newAV();
2646 PL_comppad_name_fill = 0;
2647 PL_min_intro_pending = 0;
2650 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2651 PL_curpad[0] = (SV*)newAV();
2652 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2653 #endif /* USE_THREADS */
2655 comppadlist = newAV();
2656 AvREAL_off(comppadlist);
2657 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2658 av_store(comppadlist, 1, (SV*)PL_comppad);
2659 CvPADLIST(PL_compcv) = comppadlist;
2661 if (!saveop || saveop->op_type != OP_REQUIRE)
2662 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2664 SAVEFREESV(PL_compcv);
2666 /* make sure we compile in the right package */
2668 newstash = PL_curcop->cop_stash;
2669 if (PL_curstash != newstash) {
2670 SAVESPTR(PL_curstash);
2671 PL_curstash = newstash;
2673 SAVESPTR(PL_beginav);
2674 PL_beginav = newAV();
2675 SAVEFREESV(PL_beginav);
2677 /* try to compile it */
2679 PL_eval_root = Nullop;
2681 PL_curcop = &PL_compiling;
2682 PL_curcop->cop_arybase = 0;
2683 SvREFCNT_dec(PL_rs);
2684 PL_rs = newSVpvn("\n", 1);
2685 if (saveop && saveop->op_flags & OPf_SPECIAL)
2689 if (yyparse() || PL_error_count || !PL_eval_root) {
2693 I32 optype = 0; /* Might be reset by POPEVAL. */
2698 op_free(PL_eval_root);
2699 PL_eval_root = Nullop;
2701 SP = PL_stack_base + POPMARK; /* pop original mark */
2703 POPBLOCK(cx,PL_curpm);
2709 if (optype == OP_REQUIRE) {
2710 char* msg = SvPVx(ERRSV, n_a);
2711 DIE("%s", *msg ? msg : "Compilation failed in require");
2712 } else if (startop) {
2713 char* msg = SvPVx(ERRSV, n_a);
2715 POPBLOCK(cx,PL_curpm);
2717 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2719 SvREFCNT_dec(PL_rs);
2720 PL_rs = SvREFCNT_inc(PL_nrs);
2722 MUTEX_LOCK(&PL_eval_mutex);
2724 COND_SIGNAL(&PL_eval_cond);
2725 MUTEX_UNLOCK(&PL_eval_mutex);
2726 #endif /* USE_THREADS */
2729 SvREFCNT_dec(PL_rs);
2730 PL_rs = SvREFCNT_inc(PL_nrs);
2731 PL_compiling.cop_line = 0;
2733 *startop = PL_eval_root;
2734 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2735 CvOUTSIDE(PL_compcv) = Nullcv;
2737 SAVEFREEOP(PL_eval_root);
2739 scalarvoid(PL_eval_root);
2740 else if (gimme & G_ARRAY)
2743 scalar(PL_eval_root);
2745 DEBUG_x(dump_eval());
2747 /* Register with debugger: */
2748 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2749 CV *cv = perl_get_cv("DB::postponed", FALSE);
2753 XPUSHs((SV*)PL_compiling.cop_filegv);
2755 perl_call_sv((SV*)cv, G_DISCARD);
2759 /* compiled okay, so do it */
2761 CvDEPTH(PL_compcv) = 1;
2762 SP = PL_stack_base + POPMARK; /* pop original mark */
2763 PL_op = saveop; /* The caller may need it. */
2765 MUTEX_LOCK(&PL_eval_mutex);
2767 COND_SIGNAL(&PL_eval_cond);
2768 MUTEX_UNLOCK(&PL_eval_mutex);
2769 #endif /* USE_THREADS */
2771 RETURNOP(PL_eval_start);
2777 register PERL_CONTEXT *cx;
2782 SV *namesv = Nullsv;
2784 I32 gimme = G_SCALAR;
2785 PerlIO *tryrsfp = 0;
2789 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2790 SET_NUMERIC_STANDARD();
2791 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2792 DIE("Perl %s required--this is only version %s, stopped",
2793 SvPV(sv,n_a),PL_patchlevel);
2796 name = SvPV(sv, len);
2797 if (!(name && len > 0 && *name))
2798 DIE("Null filename used");
2799 TAINT_PROPER("require");
2800 if (PL_op->op_type == OP_REQUIRE &&
2801 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2802 *svp != &PL_sv_undef)
2805 /* prepare to compile file */
2810 (name[1] == '.' && name[2] == '/')))
2812 || (name[0] && name[1] == ':')
2815 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2818 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2819 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2824 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2827 AV *ar = GvAVn(PL_incgv);
2831 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2834 namesv = NEWSV(806, 0);
2835 for (i = 0; i <= AvFILL(ar); i++) {
2836 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2839 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2841 sv_setpv(namesv, unixdir);
2842 sv_catpv(namesv, unixname);
2844 sv_setpvf(namesv, "%s/%s", dir, name);
2846 TAINT_PROPER("require");
2847 tryname = SvPVX(namesv);
2848 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2850 if (tryname[0] == '.' && tryname[1] == '/')
2857 SAVESPTR(PL_compiling.cop_filegv);
2858 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2859 SvREFCNT_dec(namesv);
2861 if (PL_op->op_type == OP_REQUIRE) {
2862 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2863 SV *dirmsgsv = NEWSV(0, 0);
2864 AV *ar = GvAVn(PL_incgv);
2866 if (instr(SvPVX(msg), ".h "))
2867 sv_catpv(msg, " (change .h to .ph maybe?)");
2868 if (instr(SvPVX(msg), ".ph "))
2869 sv_catpv(msg, " (did you run h2ph?)");
2870 sv_catpv(msg, " (@INC contains:");
2871 for (i = 0; i <= AvFILL(ar); i++) {
2872 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2873 sv_setpvf(dirmsgsv, " %s", dir);
2874 sv_catsv(msg, dirmsgsv);
2876 sv_catpvn(msg, ")", 1);
2877 SvREFCNT_dec(dirmsgsv);
2884 SETERRNO(0, SS$_NORMAL);
2886 /* Assume success here to prevent recursive requirement. */
2887 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2888 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2892 lex_start(sv_2mortal(newSVpvn("",0)));
2893 SAVEGENERICSV(PL_rsfp_filters);
2894 PL_rsfp_filters = Nullav;
2897 name = savepv(name);
2901 SAVEPPTR(PL_compiling.cop_warnings);
2902 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2905 /* switch to eval mode */
2907 push_return(PL_op->op_next);
2908 PUSHBLOCK(cx, CXt_EVAL, SP);
2909 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2911 SAVEI16(PL_compiling.cop_line);
2912 PL_compiling.cop_line = 0;
2916 MUTEX_LOCK(&PL_eval_mutex);
2917 if (PL_eval_owner && PL_eval_owner != thr)
2918 while (PL_eval_owner)
2919 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2920 PL_eval_owner = thr;
2921 MUTEX_UNLOCK(&PL_eval_mutex);
2922 #endif /* USE_THREADS */
2923 return DOCATCH(doeval(G_SCALAR, NULL));
2928 return pp_require(ARGS);
2934 register PERL_CONTEXT *cx;
2936 I32 gimme = GIMME_V, was = PL_sub_generation;
2937 char tmpbuf[TYPE_DIGITS(long) + 12];
2942 if (!SvPV(sv,len) || !len)
2944 TAINT_PROPER("eval");
2950 /* switch to eval mode */
2952 SAVESPTR(PL_compiling.cop_filegv);
2953 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2954 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2955 PL_compiling.cop_line = 1;
2956 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2957 deleting the eval's FILEGV from the stash before gv_check() runs
2958 (i.e. before run-time proper). To work around the coredump that
2959 ensues, we always turn GvMULTI_on for any globals that were
2960 introduced within evals. See force_ident(). GSAR 96-10-12 */
2961 safestr = savepv(tmpbuf);
2962 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2964 PL_hints = PL_op->op_targ;
2965 SAVEPPTR(PL_compiling.cop_warnings);
2966 if (PL_compiling.cop_warnings != WARN_ALL
2967 && PL_compiling.cop_warnings != WARN_NONE){
2968 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2969 SAVEFREESV(PL_compiling.cop_warnings) ;
2972 push_return(PL_op->op_next);
2973 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2974 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2976 /* prepare to compile string */
2978 if (PERLDB_LINE && PL_curstash != PL_debstash)
2979 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2982 MUTEX_LOCK(&PL_eval_mutex);
2983 if (PL_eval_owner && PL_eval_owner != thr)
2984 while (PL_eval_owner)
2985 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2986 PL_eval_owner = thr;
2987 MUTEX_UNLOCK(&PL_eval_mutex);
2988 #endif /* USE_THREADS */
2989 ret = doeval(gimme, NULL);
2990 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2991 && ret != PL_op->op_next) { /* Successive compilation. */
2992 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2994 return DOCATCH(ret);
3004 register PERL_CONTEXT *cx;
3006 U8 save_flags = PL_op -> op_flags;
3011 retop = pop_return();
3014 if (gimme == G_VOID)
3016 else if (gimme == G_SCALAR) {
3019 if (SvFLAGS(TOPs) & SVs_TEMP)
3022 *MARK = sv_mortalcopy(TOPs);
3026 *MARK = &PL_sv_undef;
3030 /* in case LEAVE wipes old return values */
3031 for (mark = newsp + 1; mark <= SP; mark++) {
3032 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3033 *mark = sv_mortalcopy(*mark);
3034 TAINT_NOT; /* Each item is independent */
3038 PL_curpm = newpm; /* Don't pop $1 et al till now */
3041 * Closures mentioned at top level of eval cannot be referenced
3042 * again, and their presence indirectly causes a memory leak.
3043 * (Note that the fact that compcv and friends are still set here
3044 * is, AFAIK, an accident.) --Chip
3046 if (AvFILLp(PL_comppad_name) >= 0) {
3047 SV **svp = AvARRAY(PL_comppad_name);
3049 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3051 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3053 svp[ix] = &PL_sv_undef;
3057 SvREFCNT_dec(CvOUTSIDE(sv));
3058 CvOUTSIDE(sv) = Nullcv;
3071 assert(CvDEPTH(PL_compcv) == 1);
3073 CvDEPTH(PL_compcv) = 0;
3076 if (optype == OP_REQUIRE &&
3077 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3079 /* Unassume the success we assumed earlier. */
3080 char *name = cx->blk_eval.old_name;
3081 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3082 retop = die("%s did not return a true value", name);
3083 /* die_where() did LEAVE, or we won't be here */
3087 if (!(save_flags & OPf_SPECIAL))
3097 register PERL_CONTEXT *cx;
3098 I32 gimme = GIMME_V;
3103 push_return(cLOGOP->op_other->op_next);
3104 PUSHBLOCK(cx, CXt_EVAL, SP);
3106 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3111 return DOCATCH(PL_op->op_next);
3121 register PERL_CONTEXT *cx;
3129 if (gimme == G_VOID)
3131 else if (gimme == G_SCALAR) {
3134 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3137 *MARK = sv_mortalcopy(TOPs);
3141 *MARK = &PL_sv_undef;
3146 /* in case LEAVE wipes old return values */
3147 for (mark = newsp + 1; mark <= SP; mark++) {
3148 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3149 *mark = sv_mortalcopy(*mark);
3150 TAINT_NOT; /* Each item is independent */
3154 PL_curpm = newpm; /* Don't pop $1 et al till now */
3165 register char *s = SvPV_force(sv, len);
3166 register char *send = s + len;
3167 register char *base;
3168 register I32 skipspaces = 0;
3171 bool postspace = FALSE;
3179 croak("Null picture in formline");
3181 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3186 *fpc++ = FF_LINEMARK;
3187 noblank = repeat = FALSE;
3205 case ' ': case '\t':
3216 *fpc++ = FF_LITERAL;
3224 *fpc++ = skipspaces;
3228 *fpc++ = FF_NEWLINE;
3232 arg = fpc - linepc + 1;
3239 *fpc++ = FF_LINEMARK;
3240 noblank = repeat = FALSE;
3249 ischop = s[-1] == '^';
3255 arg = (s - base) - 1;
3257 *fpc++ = FF_LITERAL;
3266 *fpc++ = FF_LINEGLOB;
3268 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3269 arg = ischop ? 512 : 0;
3279 arg |= 256 + (s - f);
3281 *fpc++ = s - base; /* fieldsize for FETCH */
3282 *fpc++ = FF_DECIMAL;
3287 bool ismore = FALSE;
3290 while (*++s == '>') ;
3291 prespace = FF_SPACE;
3293 else if (*s == '|') {
3294 while (*++s == '|') ;
3295 prespace = FF_HALFSPACE;
3300 while (*++s == '<') ;
3303 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3307 *fpc++ = s - base; /* fieldsize for FETCH */
3309 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3327 { /* need to jump to the next word */
3329 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3330 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3331 s = SvPVX(sv) + SvCUR(sv) + z;
3333 Copy(fops, s, arg, U16);
3335 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3340 * The rest of this file was derived from source code contributed
3343 * NOTE: this code was derived from Tom Horsley's qsort replacement
3344 * and should not be confused with the original code.
3347 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3349 Permission granted to distribute under the same terms as perl which are
3352 This program is free software; you can redistribute it and/or modify
3353 it under the terms of either:
3355 a) the GNU General Public License as published by the Free
3356 Software Foundation; either version 1, or (at your option) any
3359 b) the "Artistic License" which comes with this Kit.
3361 Details on the perl license can be found in the perl source code which
3362 may be located via the www.perl.com web page.
3364 This is the most wonderfulest possible qsort I can come up with (and
3365 still be mostly portable) My (limited) tests indicate it consistently
3366 does about 20% fewer calls to compare than does the qsort in the Visual
3367 C++ library, other vendors may vary.
3369 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3370 others I invented myself (or more likely re-invented since they seemed
3371 pretty obvious once I watched the algorithm operate for a while).
3373 Most of this code was written while watching the Marlins sweep the Giants
3374 in the 1997 National League Playoffs - no Braves fans allowed to use this
3375 code (just kidding :-).
3377 I realize that if I wanted to be true to the perl tradition, the only
3378 comment in this file would be something like:
3380 ...they shuffled back towards the rear of the line. 'No, not at the
3381 rear!' the slave-driver shouted. 'Three files up. And stay there...
3383 However, I really needed to violate that tradition just so I could keep
3384 track of what happens myself, not to mention some poor fool trying to
3385 understand this years from now :-).
3388 /* ********************************************************** Configuration */
3390 #ifndef QSORT_ORDER_GUESS
3391 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3394 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3395 future processing - a good max upper bound is log base 2 of memory size
3396 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3397 safely be smaller than that since the program is taking up some space and
3398 most operating systems only let you grab some subset of contiguous
3399 memory (not to mention that you are normally sorting data larger than
3400 1 byte element size :-).
3402 #ifndef QSORT_MAX_STACK
3403 #define QSORT_MAX_STACK 32
3406 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3407 Anything bigger and we use qsort. If you make this too small, the qsort
3408 will probably break (or become less efficient), because it doesn't expect
3409 the middle element of a partition to be the same as the right or left -
3410 you have been warned).
3412 #ifndef QSORT_BREAK_EVEN
3413 #define QSORT_BREAK_EVEN 6
3416 /* ************************************************************* Data Types */
3418 /* hold left and right index values of a partition waiting to be sorted (the
3419 partition includes both left and right - right is NOT one past the end or
3420 anything like that).
3422 struct partition_stack_entry {
3425 #ifdef QSORT_ORDER_GUESS
3426 int qsort_break_even;
3430 /* ******************************************************* Shorthand Macros */
3432 /* Note that these macros will be used from inside the qsort function where
3433 we happen to know that the variable 'elt_size' contains the size of an
3434 array element and the variable 'temp' points to enough space to hold a
3435 temp element and the variable 'array' points to the array being sorted
3436 and 'compare' is the pointer to the compare routine.
3438 Also note that there are very many highly architecture specific ways
3439 these might be sped up, but this is simply the most generally portable
3440 code I could think of.
3443 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3446 #define qsort_cmp(elt1, elt2) \
3447 ((this->*compare)(array[elt1], array[elt2]))
3449 #define qsort_cmp(elt1, elt2) \
3450 ((*compare)(array[elt1], array[elt2]))
3453 #ifdef QSORT_ORDER_GUESS
3454 #define QSORT_NOTICE_SWAP swapped++;
3456 #define QSORT_NOTICE_SWAP
3459 /* swaps contents of array elements elt1, elt2.
3461 #define qsort_swap(elt1, elt2) \
3464 temp = array[elt1]; \
3465 array[elt1] = array[elt2]; \
3466 array[elt2] = temp; \
3469 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3470 elt3 and elt3 gets elt1.
3472 #define qsort_rotate(elt1, elt2, elt3) \
3475 temp = array[elt1]; \
3476 array[elt1] = array[elt2]; \
3477 array[elt2] = array[elt3]; \
3478 array[elt3] = temp; \
3481 /* ************************************************************ Debug stuff */
3488 return; /* good place to set a breakpoint */
3491 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3494 doqsort_all_asserts(
3498 int (*compare)(const void * elt1, const void * elt2),
3499 int pc_left, int pc_right, int u_left, int u_right)
3503 qsort_assert(pc_left <= pc_right);
3504 qsort_assert(u_right < pc_left);
3505 qsort_assert(pc_right < u_left);
3506 for (i = u_right + 1; i < pc_left; ++i) {
3507 qsort_assert(qsort_cmp(i, pc_left) < 0);
3509 for (i = pc_left; i < pc_right; ++i) {
3510 qsort_assert(qsort_cmp(i, pc_right) == 0);
3512 for (i = pc_right + 1; i < u_left; ++i) {
3513 qsort_assert(qsort_cmp(pc_right, i) < 0);
3517 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3518 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3519 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3523 #define qsort_assert(t) ((void)0)
3525 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3529 /* ****************************************************************** qsort */
3533 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3538 I32 (*compare)(SV *a, SV *b))
3543 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3544 int next_stack_entry = 0;
3548 #ifdef QSORT_ORDER_GUESS
3549 int qsort_break_even;
3553 /* Make sure we actually have work to do.
3555 if (num_elts <= 1) {
3559 /* Setup the initial partition definition and fall into the sorting loop
3562 part_right = (int)(num_elts - 1);
3563 #ifdef QSORT_ORDER_GUESS
3564 qsort_break_even = QSORT_BREAK_EVEN;
3566 #define qsort_break_even QSORT_BREAK_EVEN
3569 if ((part_right - part_left) >= qsort_break_even) {
3570 /* OK, this is gonna get hairy, so lets try to document all the
3571 concepts and abbreviations and variables and what they keep
3574 pc: pivot chunk - the set of array elements we accumulate in the
3575 middle of the partition, all equal in value to the original
3576 pivot element selected. The pc is defined by:
3578 pc_left - the leftmost array index of the pc
3579 pc_right - the rightmost array index of the pc
3581 we start with pc_left == pc_right and only one element
3582 in the pivot chunk (but it can grow during the scan).
3584 u: uncompared elements - the set of elements in the partition
3585 we have not yet compared to the pivot value. There are two
3586 uncompared sets during the scan - one to the left of the pc
3587 and one to the right.
3589 u_right - the rightmost index of the left side's uncompared set
3590 u_left - the leftmost index of the right side's uncompared set
3592 The leftmost index of the left sides's uncompared set
3593 doesn't need its own variable because it is always defined
3594 by the leftmost edge of the whole partition (part_left). The
3595 same goes for the rightmost edge of the right partition
3598 We know there are no uncompared elements on the left once we
3599 get u_right < part_left and no uncompared elements on the
3600 right once u_left > part_right. When both these conditions
3601 are met, we have completed the scan of the partition.
3603 Any elements which are between the pivot chunk and the
3604 uncompared elements should be less than the pivot value on
3605 the left side and greater than the pivot value on the right
3606 side (in fact, the goal of the whole algorithm is to arrange
3607 for that to be true and make the groups of less-than and
3608 greater-then elements into new partitions to sort again).
3610 As you marvel at the complexity of the code and wonder why it
3611 has to be so confusing. Consider some of the things this level
3612 of confusion brings:
3614 Once I do a compare, I squeeze every ounce of juice out of it. I
3615 never do compare calls I don't have to do, and I certainly never
3618 I also never swap any elements unless I can prove there is a
3619 good reason. Many sort algorithms will swap a known value with
3620 an uncompared value just to get things in the right place (or
3621 avoid complexity :-), but that uncompared value, once it gets
3622 compared, may then have to be swapped again. A lot of the
3623 complexity of this code is due to the fact that it never swaps
3624 anything except compared values, and it only swaps them when the
3625 compare shows they are out of position.
3627 int pc_left, pc_right;
3628 int u_right, u_left;
3632 pc_left = ((part_left + part_right) / 2);
3634 u_right = pc_left - 1;
3635 u_left = pc_right + 1;
3637 /* Qsort works best when the pivot value is also the median value
3638 in the partition (unfortunately you can't find the median value
3639 without first sorting :-), so to give the algorithm a helping
3640 hand, we pick 3 elements and sort them and use the median value
3641 of that tiny set as the pivot value.
3643 Some versions of qsort like to use the left middle and right as
3644 the 3 elements to sort so they can insure the ends of the
3645 partition will contain values which will stop the scan in the
3646 compare loop, but when you have to call an arbitrarily complex
3647 routine to do a compare, its really better to just keep track of
3648 array index values to know when you hit the edge of the
3649 partition and avoid the extra compare. An even better reason to
3650 avoid using a compare call is the fact that you can drop off the
3651 edge of the array if someone foolishly provides you with an
3652 unstable compare function that doesn't always provide consistent
3655 So, since it is simpler for us to compare the three adjacent
3656 elements in the middle of the partition, those are the ones we
3657 pick here (conveniently pointed at by u_right, pc_left, and
3658 u_left). The values of the left, center, and right elements
3659 are refered to as l c and r in the following comments.
3662 #ifdef QSORT_ORDER_GUESS
3665 s = qsort_cmp(u_right, pc_left);
3668 s = qsort_cmp(pc_left, u_left);
3669 /* if l < c, c < r - already in order - nothing to do */
3671 /* l < c, c == r - already in order, pc grows */
3673 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3675 /* l < c, c > r - need to know more */
3676 s = qsort_cmp(u_right, u_left);
3678 /* l < c, c > r, l < r - swap c & r to get ordered */
3679 qsort_swap(pc_left, u_left);
3680 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3681 } else if (s == 0) {
3682 /* l < c, c > r, l == r - swap c&r, grow pc */
3683 qsort_swap(pc_left, u_left);
3685 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3687 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3688 qsort_rotate(pc_left, u_right, u_left);
3689 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3692 } else if (s == 0) {
3694 s = qsort_cmp(pc_left, u_left);
3696 /* l == c, c < r - already in order, grow pc */
3698 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3699 } else if (s == 0) {
3700 /* l == c, c == r - already in order, grow pc both ways */
3703 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3705 /* l == c, c > r - swap l & r, grow pc */
3706 qsort_swap(u_right, u_left);
3708 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3712 s = qsort_cmp(pc_left, u_left);
3714 /* l > c, c < r - need to know more */
3715 s = qsort_cmp(u_right, u_left);
3717 /* l > c, c < r, l < r - swap l & c to get ordered */
3718 qsort_swap(u_right, pc_left);
3719 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3720 } else if (s == 0) {
3721 /* l > c, c < r, l == r - swap l & c, grow pc */
3722 qsort_swap(u_right, pc_left);
3724 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3726 /* l > c, c < r, l > r - rotate lcr into crl to order */
3727 qsort_rotate(u_right, pc_left, u_left);
3728 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3730 } else if (s == 0) {
3731 /* l > c, c == r - swap ends, grow pc */
3732 qsort_swap(u_right, u_left);
3734 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3736 /* l > c, c > r - swap ends to get in order */
3737 qsort_swap(u_right, u_left);
3738 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3741 /* We now know the 3 middle elements have been compared and
3742 arranged in the desired order, so we can shrink the uncompared
3747 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3749 /* The above massive nested if was the simple part :-). We now have
3750 the middle 3 elements ordered and we need to scan through the
3751 uncompared sets on either side, swapping elements that are on
3752 the wrong side or simply shuffling equal elements around to get
3753 all equal elements into the pivot chunk.
3757 int still_work_on_left;
3758 int still_work_on_right;
3760 /* Scan the uncompared values on the left. If I find a value
3761 equal to the pivot value, move it over so it is adjacent to
3762 the pivot chunk and expand the pivot chunk. If I find a value
3763 less than the pivot value, then just leave it - its already
3764 on the correct side of the partition. If I find a greater
3765 value, then stop the scan.
3767 while (still_work_on_left = (u_right >= part_left)) {
3768 s = qsort_cmp(u_right, pc_left);
3771 } else if (s == 0) {
3773 if (pc_left != u_right) {
3774 qsort_swap(u_right, pc_left);
3780 qsort_assert(u_right < pc_left);
3781 qsort_assert(pc_left <= pc_right);
3782 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3783 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3786 /* Do a mirror image scan of uncompared values on the right
3788 while (still_work_on_right = (u_left <= part_right)) {
3789 s = qsort_cmp(pc_right, u_left);
3792 } else if (s == 0) {
3794 if (pc_right != u_left) {
3795 qsort_swap(pc_right, u_left);
3801 qsort_assert(u_left > pc_right);
3802 qsort_assert(pc_left <= pc_right);
3803 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3804 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3807 if (still_work_on_left) {
3808 /* I know I have a value on the left side which needs to be
3809 on the right side, but I need to know more to decide
3810 exactly the best thing to do with it.
3812 if (still_work_on_right) {
3813 /* I know I have values on both side which are out of
3814 position. This is a big win because I kill two birds
3815 with one swap (so to speak). I can advance the
3816 uncompared pointers on both sides after swapping both
3817 of them into the right place.
3819 qsort_swap(u_right, u_left);
3822 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3824 /* I have an out of position value on the left, but the
3825 right is fully scanned, so I "slide" the pivot chunk
3826 and any less-than values left one to make room for the
3827 greater value over on the right. If the out of position
3828 value is immediately adjacent to the pivot chunk (there
3829 are no less-than values), I can do that with a swap,
3830 otherwise, I have to rotate one of the less than values
3831 into the former position of the out of position value
3832 and the right end of the pivot chunk into the left end
3836 if (pc_left == u_right) {
3837 qsort_swap(u_right, pc_right);
3838 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3840 qsort_rotate(u_right, pc_left, pc_right);
3841 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3846 } else if (still_work_on_right) {
3847 /* Mirror image of complex case above: I have an out of
3848 position value on the right, but the left is fully
3849 scanned, so I need to shuffle things around to make room
3850 for the right value on the left.
3853 if (pc_right == u_left) {
3854 qsort_swap(u_left, pc_left);
3855 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3857 qsort_rotate(pc_right, pc_left, u_left);
3858 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3863 /* No more scanning required on either side of partition,
3864 break out of loop and figure out next set of partitions
3870 /* The elements in the pivot chunk are now in the right place. They
3871 will never move or be compared again. All I have to do is decide
3872 what to do with the stuff to the left and right of the pivot
3875 Notes on the QSORT_ORDER_GUESS ifdef code:
3877 1. If I just built these partitions without swapping any (or
3878 very many) elements, there is a chance that the elements are
3879 already ordered properly (being properly ordered will
3880 certainly result in no swapping, but the converse can't be
3883 2. A (properly written) insertion sort will run faster on
3884 already ordered data than qsort will.
3886 3. Perhaps there is some way to make a good guess about
3887 switching to an insertion sort earlier than partition size 6
3888 (for instance - we could save the partition size on the stack
3889 and increase the size each time we find we didn't swap, thus
3890 switching to insertion sort earlier for partitions with a
3891 history of not swapping).
3893 4. Naturally, if I just switch right away, it will make
3894 artificial benchmarks with pure ascending (or descending)
3895 data look really good, but is that a good reason in general?
3899 #ifdef QSORT_ORDER_GUESS
3901 #if QSORT_ORDER_GUESS == 1
3902 qsort_break_even = (part_right - part_left) + 1;
3904 #if QSORT_ORDER_GUESS == 2
3905 qsort_break_even *= 2;
3907 #if QSORT_ORDER_GUESS == 3
3908 int prev_break = qsort_break_even;
3909 qsort_break_even *= qsort_break_even;
3910 if (qsort_break_even < prev_break) {
3911 qsort_break_even = (part_right - part_left) + 1;
3915 qsort_break_even = QSORT_BREAK_EVEN;
3919 if (part_left < pc_left) {
3920 /* There are elements on the left which need more processing.
3921 Check the right as well before deciding what to do.
3923 if (pc_right < part_right) {
3924 /* We have two partitions to be sorted. Stack the biggest one
3925 and process the smallest one on the next iteration. This
3926 minimizes the stack height by insuring that any additional
3927 stack entries must come from the smallest partition which
3928 (because it is smallest) will have the fewest
3929 opportunities to generate additional stack entries.
3931 if ((part_right - pc_right) > (pc_left - part_left)) {
3932 /* stack the right partition, process the left */
3933 partition_stack[next_stack_entry].left = pc_right + 1;
3934 partition_stack[next_stack_entry].right = part_right;
3935 #ifdef QSORT_ORDER_GUESS
3936 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3938 part_right = pc_left - 1;
3940 /* stack the left partition, process the right */
3941 partition_stack[next_stack_entry].left = part_left;
3942 partition_stack[next_stack_entry].right = pc_left - 1;
3943 #ifdef QSORT_ORDER_GUESS
3944 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3946 part_left = pc_right + 1;
3948 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3951 /* The elements on the left are the only remaining elements
3952 that need sorting, arrange for them to be processed as the
3955 part_right = pc_left - 1;
3957 } else if (pc_right < part_right) {
3958 /* There is only one chunk on the right to be sorted, make it
3959 the new partition and loop back around.
3961 part_left = pc_right + 1;
3963 /* This whole partition wound up in the pivot chunk, so
3964 we need to get a new partition off the stack.
3966 if (next_stack_entry == 0) {
3967 /* the stack is empty - we are done */
3971 part_left = partition_stack[next_stack_entry].left;
3972 part_right = partition_stack[next_stack_entry].right;
3973 #ifdef QSORT_ORDER_GUESS
3974 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3978 /* This partition is too small to fool with qsort complexity, just
3979 do an ordinary insertion sort to minimize overhead.
3982 /* Assume 1st element is in right place already, and start checking
3983 at 2nd element to see where it should be inserted.
3985 for (i = part_left + 1; i <= part_right; ++i) {
3987 /* Scan (backwards - just in case 'i' is already in right place)
3988 through the elements already sorted to see if the ith element
3989 belongs ahead of one of them.
3991 for (j = i - 1; j >= part_left; --j) {
3992 if (qsort_cmp(i, j) >= 0) {
3993 /* i belongs right after j
4000 /* Looks like we really need to move some things
4004 for (k = i - 1; k >= j; --k)
4005 array[k + 1] = array[k];
4010 /* That partition is now sorted, grab the next one, or get out
4011 of the loop if there aren't any more.
4014 if (next_stack_entry == 0) {
4015 /* the stack is empty - we are done */
4019 part_left = partition_stack[next_stack_entry].left;
4020 part_right = partition_stack[next_stack_entry].right;
4021 #ifdef QSORT_ORDER_GUESS
4022 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4027 /* Believe it or not, the array is sorted at this point! */