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 PerlIO *doopen _((const char *name, const char *mode));
45 static I32 sv_ncmp _((SV *a, SV *b));
46 static I32 sv_i_ncmp _((SV *a, SV *b));
47 static I32 amagic_ncmp _((SV *a, SV *b));
48 static I32 amagic_i_ncmp _((SV *a, SV *b));
49 static I32 amagic_cmp _((SV *str1, SV *str2));
50 static I32 amagic_cmp_locale _((SV *str1, SV *str2));
59 cxix = dopoptosub(cxstack_ix);
63 switch (cxstack[cxix].blk_gimme) {
80 /* XXXX Should store the old value to allow for tie/overload - and
81 restore in regcomp, where marked with XXXX. */
89 register PMOP *pm = (PMOP*)cLOGOP->op_other;
93 MAGIC *mg = Null(MAGIC*);
97 SV *sv = SvRV(tmpstr);
99 mg = mg_find(sv, 'r');
102 regexp *re = (regexp *)mg->mg_obj;
103 ReREFCNT_dec(pm->op_pmregexp);
104 pm->op_pmregexp = ReREFCNT_inc(re);
107 t = SvPV(tmpstr, len);
109 /* Check against the last compiled regexp. */
110 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
111 pm->op_pmregexp->prelen != len ||
112 memNE(pm->op_pmregexp->precomp, t, len))
114 if (pm->op_pmregexp) {
115 ReREFCNT_dec(pm->op_pmregexp);
116 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
118 if (PL_op->op_flags & OPf_SPECIAL)
119 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
121 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
122 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
123 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
124 inside tie/overload accessors. */
128 #ifndef INCOMPLETE_TAINTS
131 pm->op_pmdynflags |= PMdf_TAINTED;
133 pm->op_pmdynflags &= ~PMdf_TAINTED;
137 if (!pm->op_pmregexp->prelen && PL_curpm)
139 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
140 pm->op_pmflags |= PMf_WHITE;
142 if (pm->op_pmflags & PMf_KEEP) {
143 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
144 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
162 if (cx->sb_iters++) {
163 if (cx->sb_iters > cx->sb_maxiters)
164 DIE("Substitution loop");
166 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
167 cx->sb_rxtainted |= 2;
168 sv_catsv(dstr, POPs);
171 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
172 s == m, cx->sb_targ, NULL,
173 ((cx->sb_rflags & REXEC_COPY_STR)
175 : (REXEC_COPY_STR|REXEC_IGNOREPOS))))
177 SV *targ = cx->sb_targ;
178 sv_catpvn(dstr, s, cx->sb_strend - s);
180 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
182 (void)SvOOK_off(targ);
183 Safefree(SvPVX(targ));
184 SvPVX(targ) = SvPVX(dstr);
185 SvCUR_set(targ, SvCUR(dstr));
186 SvLEN_set(targ, SvLEN(dstr));
190 TAINT_IF(cx->sb_rxtainted & 1);
191 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
193 (void)SvPOK_only(targ);
194 TAINT_IF(cx->sb_rxtainted);
198 LEAVE_SCOPE(cx->sb_oldsave);
200 RETURNOP(pm->op_next);
203 if (rx->subbase && rx->subbase != orig) {
206 cx->sb_orig = orig = rx->subbase;
208 cx->sb_strend = s + (cx->sb_strend - m);
210 cx->sb_m = m = rx->startp[0];
211 sv_catpvn(dstr, s, m-s);
212 cx->sb_s = rx->endp[0];
213 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
214 rxres_save(&cx->sb_rxres, rx);
215 RETURNOP(pm->op_pmreplstart);
219 rxres_save(void **rsp, REGEXP *rx)
224 if (!p || p[1] < rx->nparens) {
225 i = 6 + rx->nparens * 2;
233 *p++ = (UV)rx->subbase;
234 rx->subbase = Nullch;
238 *p++ = (UV)rx->subbeg;
239 *p++ = (UV)rx->subend;
240 for (i = 0; i <= rx->nparens; ++i) {
241 *p++ = (UV)rx->startp[i];
242 *p++ = (UV)rx->endp[i];
247 rxres_restore(void **rsp, REGEXP *rx)
252 Safefree(rx->subbase);
253 rx->subbase = (char*)(*p);
258 rx->subbeg = (char*)(*p++);
259 rx->subend = (char*)(*p++);
260 for (i = 0; i <= rx->nparens; ++i) {
261 rx->startp[i] = (char*)(*p++);
262 rx->endp[i] = (char*)(*p++);
267 rxres_free(void **rsp)
272 Safefree((char*)(*p));
280 djSP; dMARK; dORIGMARK;
281 register SV *tmpForm = *++MARK;
293 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
299 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
301 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
302 SvREADONLY_off(tmpForm);
303 doparseform(tmpForm);
306 SvPV_force(PL_formtarget, len);
307 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
309 f = SvPV(tmpForm, len);
310 /* need to jump to the next word */
311 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
320 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
321 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
322 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
323 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
324 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
326 case FF_CHECKNL: name = "CHECKNL"; break;
327 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
328 case FF_SPACE: name = "SPACE"; break;
329 case FF_HALFSPACE: name = "HALFSPACE"; break;
330 case FF_ITEM: name = "ITEM"; break;
331 case FF_CHOP: name = "CHOP"; break;
332 case FF_LINEGLOB: name = "LINEGLOB"; break;
333 case FF_NEWLINE: name = "NEWLINE"; break;
334 case FF_MORE: name = "MORE"; break;
335 case FF_LINEMARK: name = "LINEMARK"; break;
336 case FF_END: name = "END"; break;
339 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
341 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
369 if (ckWARN(WARN_SYNTAX))
370 warner(WARN_SYNTAX, "Not enough format arguments");
375 item = s = SvPV(sv, len);
378 itemsize = sv_len_utf8(sv);
379 if (itemsize != len) {
381 if (itemsize > fieldsize) {
382 itemsize = fieldsize;
383 itembytes = itemsize;
384 sv_pos_u2b(sv, &itembytes, 0);
388 send = chophere = s + itembytes;
397 sv_pos_b2u(sv, &itemsize);
401 if (itemsize > fieldsize)
402 itemsize = fieldsize;
403 send = chophere = s + itemsize;
415 item = s = SvPV(sv, len);
418 itemsize = sv_len_utf8(sv);
419 if (itemsize != len) {
421 if (itemsize <= fieldsize) {
422 send = chophere = s + itemsize;
433 itemsize = fieldsize;
434 itembytes = itemsize;
435 sv_pos_u2b(sv, &itembytes, 0);
436 send = chophere = s + itembytes;
437 while (s < send || (s == send && isSPACE(*s))) {
447 if (strchr(PL_chopset, *s))
452 itemsize = chophere - item;
453 sv_pos_b2u(sv, &itemsize);
458 if (itemsize <= fieldsize) {
459 send = chophere = s + itemsize;
470 itemsize = fieldsize;
471 send = chophere = s + itemsize;
472 while (s < send || (s == send && isSPACE(*s))) {
482 if (strchr(PL_chopset, *s))
487 itemsize = chophere - item;
492 arg = fieldsize - itemsize;
501 arg = fieldsize - itemsize;
516 switch (UTF8SKIP(s)) {
527 if ( !((*t++ = *s++) & ~31) )
535 int ch = *t++ = *s++;
538 if ( !((*t++ = *s++) & ~31) )
547 while (*s && isSPACE(*s))
554 item = s = SvPV(sv, len);
567 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
568 sv_catpvn(PL_formtarget, item, itemsize);
569 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
570 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
575 /* If the field is marked with ^ and the value is undefined,
578 if ((arg & 512) && !SvOK(sv)) {
586 /* Formats aren't yet marked for locales, so assume "yes". */
589 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
591 sprintf(t, "%*.0f", (int) fieldsize, value);
598 while (t-- > linemark && *t == ' ') ;
606 if (arg) { /* repeat until fields exhausted? */
608 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
609 lines += FmLINES(PL_formtarget);
612 if (strnEQ(linemark, linemark - arg, arg))
613 DIE("Runaway format");
615 FmLINES(PL_formtarget) = lines;
617 RETURNOP(cLISTOP->op_first);
630 while (*s && isSPACE(*s) && s < send)
634 arg = fieldsize - itemsize;
641 if (strnEQ(s," ",3)) {
642 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
653 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
654 FmLINES(PL_formtarget) += lines;
666 if (PL_stack_base + *PL_markstack_ptr == SP) {
668 if (GIMME_V == G_SCALAR)
670 RETURNOP(PL_op->op_next->op_next);
672 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
673 pp_pushmark(ARGS); /* push dst */
674 pp_pushmark(ARGS); /* push src */
675 ENTER; /* enter outer scope */
678 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
680 ENTER; /* enter inner scope */
683 src = PL_stack_base[*PL_markstack_ptr];
688 if (PL_op->op_type == OP_MAPSTART)
689 pp_pushmark(ARGS); /* push top */
690 return ((LOGOP*)PL_op->op_next)->op_other;
695 DIE("panic: mapstart"); /* uses grepstart */
701 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
707 ++PL_markstack_ptr[-1];
709 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
710 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
711 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
716 PL_markstack_ptr[-1] += shift;
717 *PL_markstack_ptr += shift;
721 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
724 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
726 LEAVE; /* exit inner scope */
729 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
733 (void)POPMARK; /* pop top */
734 LEAVE; /* exit outer scope */
735 (void)POPMARK; /* pop src */
736 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
737 (void)POPMARK; /* pop dst */
738 SP = PL_stack_base + POPMARK; /* pop original mark */
739 if (gimme == G_SCALAR) {
743 else if (gimme == G_ARRAY)
750 ENTER; /* enter inner scope */
753 src = PL_stack_base[PL_markstack_ptr[-1]];
757 RETURNOP(cLOGOP->op_other);
762 sv_ncmp (SV *a, SV *b)
764 double nv1 = SvNV(a);
765 double nv2 = SvNV(b);
766 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
769 sv_i_ncmp (SV *a, SV *b)
773 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
775 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
777 if (PL_amagic_generation) { \
778 if (SvAMAGIC(left)||SvAMAGIC(right))\
779 *svp = amagic_call(left, \
787 amagic_ncmp(register SV *a, register SV *b)
790 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
795 I32 i = SvIVX(tmpsv);
805 return sv_ncmp(a, b);
809 amagic_i_ncmp(register SV *a, register SV *b)
812 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
817 I32 i = SvIVX(tmpsv);
827 return sv_i_ncmp(a, b);
831 amagic_cmp(register SV *str1, register SV *str2)
834 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
839 I32 i = SvIVX(tmpsv);
849 return sv_cmp(str1, str2);
853 amagic_cmp_locale(register SV *str1, register SV *str2)
856 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
861 I32 i = SvIVX(tmpsv);
871 return sv_cmp_locale(str1, str2);
876 djSP; dMARK; dORIGMARK;
878 SV **myorigmark = ORIGMARK;
884 OP* nextop = PL_op->op_next;
887 if (gimme != G_ARRAY) {
893 SAVEPPTR(PL_sortcop);
894 if (PL_op->op_flags & OPf_STACKED) {
895 if (PL_op->op_flags & OPf_SPECIAL) {
896 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
897 kid = kUNOP->op_first; /* pass rv2gv */
898 kid = kUNOP->op_first; /* pass leave */
899 PL_sortcop = kid->op_next;
900 stash = PL_curcop->cop_stash;
903 cv = sv_2cv(*++MARK, &stash, &gv, 0);
904 if (!(cv && CvROOT(cv))) {
906 SV *tmpstr = sv_newmortal();
907 gv_efullname3(tmpstr, gv, Nullch);
908 if (cv && CvXSUB(cv))
909 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
910 DIE("Undefined sort subroutine \"%s\" called",
915 DIE("Xsub called in sort");
916 DIE("Undefined subroutine in sort");
918 DIE("Not a CODE reference in sort");
920 PL_sortcop = CvSTART(cv);
921 SAVESPTR(CvROOT(cv)->op_ppaddr);
922 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
925 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
930 stash = PL_curcop->cop_stash;
934 while (MARK < SP) { /* This may or may not shift down one here. */
936 if (*up = *++MARK) { /* Weed out nulls. */
938 if (!PL_sortcop && !SvPOK(*up)) {
943 (void)sv_2pv(*up, &n_a);
948 max = --up - myorigmark;
953 bool oldcatch = CATCH_GET;
959 PUSHSTACKi(PERLSI_SORT);
960 if (PL_sortstash != stash) {
961 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
962 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
963 PL_sortstash = stash;
966 SAVESPTR(GvSV(PL_firstgv));
967 SAVESPTR(GvSV(PL_secondgv));
969 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
970 if (!(PL_op->op_flags & OPf_SPECIAL)) {
971 bool hasargs = FALSE;
972 cx->cx_type = CXt_SUB;
973 cx->blk_gimme = G_SCALAR;
976 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
978 PL_sortcxix = cxstack_ix;
979 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
981 POPBLOCK(cx,PL_curpm);
989 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
990 qsortsv(ORIGMARK+1, max,
991 (PL_op->op_private & OPpSORT_NUMERIC)
992 ? ( (PL_op->op_private & OPpSORT_INTEGER)
994 ? FUNC_NAME_TO_PTR(amagic_i_ncmp)
995 : FUNC_NAME_TO_PTR(sv_i_ncmp))
997 ? FUNC_NAME_TO_PTR(amagic_ncmp)
998 : FUNC_NAME_TO_PTR(sv_ncmp)))
999 : ( (PL_op->op_private & OPpLOCALE)
1001 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
1002 : FUNC_NAME_TO_PTR(sv_cmp_locale))
1004 ? FUNC_NAME_TO_PTR(amagic_cmp)
1005 : FUNC_NAME_TO_PTR(sv_cmp) )));
1006 if (PL_op->op_private & OPpSORT_REVERSE) {
1007 SV **p = ORIGMARK+1;
1008 SV **q = ORIGMARK+max;
1018 PL_stack_sp = ORIGMARK + max;
1026 if (GIMME == G_ARRAY)
1027 return cCONDOP->op_true;
1028 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
1035 if (GIMME == G_ARRAY) {
1036 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1040 SV *targ = PAD_SV(PL_op->op_targ);
1042 if ((PL_op->op_private & OPpFLIP_LINENUM)
1043 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1045 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1046 if (PL_op->op_flags & OPf_SPECIAL) {
1054 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1067 if (GIMME == G_ARRAY) {
1073 if (SvGMAGICAL(left))
1075 if (SvGMAGICAL(right))
1078 if (SvNIOKp(left) || !SvPOKp(left) ||
1079 (looks_like_number(left) && *SvPVX(left) != '0') )
1081 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1082 croak("Range iterator outside integer range");
1093 sv = sv_2mortal(newSViv(i++));
1098 SV *final = sv_mortalcopy(right);
1100 char *tmps = SvPV(final, len);
1102 sv = sv_mortalcopy(left);
1104 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1106 if (strEQ(SvPVX(sv),tmps))
1108 sv = sv_2mortal(newSVsv(sv));
1115 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1117 if ((PL_op->op_private & OPpFLIP_LINENUM)
1118 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1120 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1121 sv_catpv(targ, "E0");
1132 dopoptolabel(char *label)
1136 register PERL_CONTEXT *cx;
1138 for (i = cxstack_ix; i >= 0; i--) {
1140 switch (CxTYPE(cx)) {
1142 if (ckWARN(WARN_UNSAFE))
1143 warner(WARN_UNSAFE, "Exiting substitution via %s",
1144 PL_op_name[PL_op->op_type]);
1147 if (ckWARN(WARN_UNSAFE))
1148 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1149 PL_op_name[PL_op->op_type]);
1152 if (ckWARN(WARN_UNSAFE))
1153 warner(WARN_UNSAFE, "Exiting eval via %s",
1154 PL_op_name[PL_op->op_type]);
1157 if (ckWARN(WARN_UNSAFE))
1158 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1159 PL_op_name[PL_op->op_type]);
1162 if (!cx->blk_loop.label ||
1163 strNE(label, cx->blk_loop.label) ) {
1164 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1165 (long)i, cx->blk_loop.label));
1168 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1178 I32 gimme = block_gimme();
1179 return (gimme == G_VOID) ? G_SCALAR : gimme;
1188 cxix = dopoptosub(cxstack_ix);
1192 switch (cxstack[cxix].blk_gimme) {
1200 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1207 dopoptosub(I32 startingblock)
1210 return dopoptosub_at(cxstack, startingblock);
1214 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1218 register PERL_CONTEXT *cx;
1219 for (i = startingblock; i >= 0; i--) {
1221 switch (CxTYPE(cx)) {
1226 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1234 dopoptoeval(I32 startingblock)
1238 register PERL_CONTEXT *cx;
1239 for (i = startingblock; i >= 0; i--) {
1241 switch (CxTYPE(cx)) {
1245 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1253 dopoptoloop(I32 startingblock)
1257 register PERL_CONTEXT *cx;
1258 for (i = startingblock; i >= 0; i--) {
1260 switch (CxTYPE(cx)) {
1262 if (ckWARN(WARN_UNSAFE))
1263 warner(WARN_UNSAFE, "Exiting substitution via %s",
1264 PL_op_name[PL_op->op_type]);
1267 if (ckWARN(WARN_UNSAFE))
1268 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1269 PL_op_name[PL_op->op_type]);
1272 if (ckWARN(WARN_UNSAFE))
1273 warner(WARN_UNSAFE, "Exiting eval via %s",
1274 PL_op_name[PL_op->op_type]);
1277 if (ckWARN(WARN_UNSAFE))
1278 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1279 PL_op_name[PL_op->op_type]);
1282 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1293 register PERL_CONTEXT *cx;
1297 while (cxstack_ix > cxix) {
1298 cx = &cxstack[cxstack_ix];
1299 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1300 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1301 /* Note: we don't need to restore the base context info till the end. */
1302 switch (CxTYPE(cx)) {
1305 continue; /* not break */
1323 die_where(char *message, STRLEN msglen)
1329 register PERL_CONTEXT *cx;
1334 if (PL_in_eval & 4) {
1337 svp = hv_fetch(ERRHV, message, msglen, 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)+msglen);
1347 sv_catpvn(err, prefix, sizeof(prefix)-1);
1348 sv_catpvn(err, message, msglen);
1349 if (ckWARN(WARN_UNSAFE)) {
1350 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1351 warner(WARN_UNSAFE, SvPVX(err)+start);
1358 sv_setpvn(ERRSV, message, msglen);
1361 message = SvPVx(ERRSV, msglen);
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_write(PerlIO_stderr(), "panic: die ", 11);
1377 PerlIO_write(PerlIO_stderr(), message, msglen);
1382 if (gimme == G_SCALAR)
1383 *++newsp = &PL_sv_undef;
1384 PL_stack_sp = newsp;
1388 if (optype == OP_REQUIRE) {
1389 char* msg = SvPVx(ERRSV, n_a);
1390 DIE("%s", *msg ? msg : "Compilation failed in require");
1392 return pop_return();
1396 message = SvPVx(ERRSV, msglen);
1399 /* SFIO can really mess with your errno */
1402 PerlIO_write(PerlIO_stderr(), message, msglen);
1403 (void)PerlIO_flush(PerlIO_stderr());
1416 if (SvTRUE(left) != SvTRUE(right))
1428 RETURNOP(cLOGOP->op_other);
1437 RETURNOP(cLOGOP->op_other);
1443 register I32 cxix = dopoptosub(cxstack_ix);
1444 register PERL_CONTEXT *cx;
1445 register PERL_CONTEXT *ccstack = cxstack;
1446 PERL_SI *top_si = PL_curstackinfo;
1457 /* we may be in a higher stacklevel, so dig down deeper */
1458 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1459 top_si = top_si->si_prev;
1460 ccstack = top_si->si_cxstack;
1461 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1464 if (GIMME != G_ARRAY)
1468 if (PL_DBsub && cxix >= 0 &&
1469 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1473 cxix = dopoptosub_at(ccstack, cxix - 1);
1476 cx = &ccstack[cxix];
1477 if (CxTYPE(cx) == CXt_SUB) {
1478 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1479 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1480 field below is defined for any cx. */
1481 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1482 cx = &ccstack[dbcxix];
1485 if (GIMME != G_ARRAY) {
1486 hv = cx->blk_oldcop->cop_stash;
1488 PUSHs(&PL_sv_undef);
1491 sv_setpv(TARG, HvNAME(hv));
1497 hv = cx->blk_oldcop->cop_stash;
1499 PUSHs(&PL_sv_undef);
1501 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1502 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1503 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1504 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1507 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1509 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1510 PUSHs(sv_2mortal(sv));
1511 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1514 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1515 PUSHs(sv_2mortal(newSViv(0)));
1517 gimme = (I32)cx->blk_gimme;
1518 if (gimme == G_VOID)
1519 PUSHs(&PL_sv_undef);
1521 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1522 if (CxTYPE(cx) == CXt_EVAL) {
1523 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1524 PUSHs(cx->blk_eval.cur_text);
1527 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1528 /* Require, put the name. */
1529 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1533 else if (CxTYPE(cx) == CXt_SUB &&
1534 cx->blk_sub.hasargs &&
1535 PL_curcop->cop_stash == PL_debstash)
1537 AV *ary = cx->blk_sub.argarray;
1538 int off = AvARRAY(ary) - AvALLOC(ary);
1542 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1545 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1548 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1549 av_extend(PL_dbargs, AvFILLp(ary) + off);
1550 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1551 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1557 sortcv(SV *a, SV *b)
1560 I32 oldsaveix = PL_savestack_ix;
1561 I32 oldscopeix = PL_scopestack_ix;
1563 GvSV(PL_firstgv) = a;
1564 GvSV(PL_secondgv) = b;
1565 PL_stack_sp = PL_stack_base;
1568 if (PL_stack_sp != PL_stack_base + 1)
1569 croak("Sort subroutine didn't return single value");
1570 if (!SvNIOKp(*PL_stack_sp))
1571 croak("Sort subroutine didn't return a numeric value");
1572 result = SvIV(*PL_stack_sp);
1573 while (PL_scopestack_ix > oldscopeix) {
1576 leave_scope(oldsaveix);
1590 sv_reset(tmps, PL_curcop->cop_stash);
1602 PL_curcop = (COP*)PL_op;
1603 TAINT_NOT; /* Each statement is presumed innocent */
1604 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1607 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1611 register PERL_CONTEXT *cx;
1612 I32 gimme = G_ARRAY;
1619 DIE("No DB::DB routine defined");
1621 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1633 push_return(PL_op->op_next);
1634 PUSHBLOCK(cx, CXt_SUB, SP);
1637 (void)SvREFCNT_inc(cv);
1638 SAVESPTR(PL_curpad);
1639 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1640 RETURNOP(CvSTART(cv));
1654 register PERL_CONTEXT *cx;
1655 I32 gimme = GIMME_V;
1662 if (PL_op->op_flags & OPf_SPECIAL) {
1664 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1665 SAVEGENERICSV(*svp);
1669 #endif /* USE_THREADS */
1670 if (PL_op->op_targ) {
1671 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1675 svp = &GvSV((GV*)POPs); /* symbol table variable */
1676 SAVEGENERICSV(*svp);
1682 PUSHBLOCK(cx, CXt_LOOP, SP);
1683 PUSHLOOP(cx, svp, MARK);
1684 if (PL_op->op_flags & OPf_STACKED) {
1685 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1686 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1688 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1689 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1690 if (SvNV(sv) < IV_MIN ||
1691 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1692 croak("Range iterator outside integer range");
1693 cx->blk_loop.iterix = SvIV(sv);
1694 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1697 cx->blk_loop.iterlval = newSVsv(sv);
1701 cx->blk_loop.iterary = PL_curstack;
1702 AvFILLp(PL_curstack) = SP - PL_stack_base;
1703 cx->blk_loop.iterix = MARK - PL_stack_base;
1712 register PERL_CONTEXT *cx;
1713 I32 gimme = GIMME_V;
1719 PUSHBLOCK(cx, CXt_LOOP, SP);
1720 PUSHLOOP(cx, 0, SP);
1728 register PERL_CONTEXT *cx;
1729 struct block_loop cxloop;
1737 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1740 if (gimme == G_VOID)
1742 else if (gimme == G_SCALAR) {
1744 *++newsp = sv_mortalcopy(*SP);
1746 *++newsp = &PL_sv_undef;
1750 *++newsp = sv_mortalcopy(*++mark);
1751 TAINT_NOT; /* Each item is independent */
1757 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1758 PL_curpm = newpm; /* ... and pop $1 et al */
1770 register PERL_CONTEXT *cx;
1771 struct block_sub cxsub;
1772 bool popsub2 = FALSE;
1778 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1779 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1780 if (cxstack_ix > PL_sortcxix)
1781 dounwind(PL_sortcxix);
1782 AvARRAY(PL_curstack)[1] = *SP;
1783 PL_stack_sp = PL_stack_base + 1;
1788 cxix = dopoptosub(cxstack_ix);
1790 DIE("Can't return outside a subroutine");
1791 if (cxix < cxstack_ix)
1795 switch (CxTYPE(cx)) {
1797 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1802 if (optype == OP_REQUIRE &&
1803 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1805 /* Unassume the success we assumed earlier. */
1806 char *name = cx->blk_eval.old_name;
1807 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1808 DIE("%s did not return a true value", name);
1812 DIE("panic: return");
1816 if (gimme == G_SCALAR) {
1819 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1821 *++newsp = SvREFCNT_inc(*SP);
1826 *++newsp = sv_mortalcopy(*SP);
1829 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1831 *++newsp = sv_mortalcopy(*SP);
1833 *++newsp = &PL_sv_undef;
1835 else if (gimme == G_ARRAY) {
1836 while (++MARK <= SP) {
1837 *++newsp = (popsub2 && SvTEMP(*MARK))
1838 ? *MARK : sv_mortalcopy(*MARK);
1839 TAINT_NOT; /* Each item is independent */
1842 PL_stack_sp = newsp;
1844 /* Stack values are safe: */
1846 POPSUB2(); /* release CV and @_ ... */
1848 PL_curpm = newpm; /* ... and pop $1 et al */
1851 return pop_return();
1858 register PERL_CONTEXT *cx;
1859 struct block_loop cxloop;
1860 struct block_sub cxsub;
1867 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1869 if (PL_op->op_flags & OPf_SPECIAL) {
1870 cxix = dopoptoloop(cxstack_ix);
1872 DIE("Can't \"last\" outside a block");
1875 cxix = dopoptolabel(cPVOP->op_pv);
1877 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1879 if (cxix < cxstack_ix)
1883 switch (CxTYPE(cx)) {
1885 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1887 nextop = cxloop.last_op->op_next;
1890 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1892 nextop = pop_return();
1896 nextop = pop_return();
1903 if (gimme == G_SCALAR) {
1905 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1906 ? *SP : sv_mortalcopy(*SP);
1908 *++newsp = &PL_sv_undef;
1910 else if (gimme == G_ARRAY) {
1911 while (++MARK <= SP) {
1912 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1913 ? *MARK : sv_mortalcopy(*MARK);
1914 TAINT_NOT; /* Each item is independent */
1920 /* Stack values are safe: */
1923 POPLOOP2(); /* release loop vars ... */
1927 POPSUB2(); /* release CV and @_ ... */
1930 PL_curpm = newpm; /* ... and pop $1 et al */
1939 register PERL_CONTEXT *cx;
1942 if (PL_op->op_flags & OPf_SPECIAL) {
1943 cxix = dopoptoloop(cxstack_ix);
1945 DIE("Can't \"next\" outside a block");
1948 cxix = dopoptolabel(cPVOP->op_pv);
1950 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1952 if (cxix < cxstack_ix)
1956 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1957 LEAVE_SCOPE(oldsave);
1958 return cx->blk_loop.next_op;
1964 register PERL_CONTEXT *cx;
1967 if (PL_op->op_flags & OPf_SPECIAL) {
1968 cxix = dopoptoloop(cxstack_ix);
1970 DIE("Can't \"redo\" outside a block");
1973 cxix = dopoptolabel(cPVOP->op_pv);
1975 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1977 if (cxix < cxstack_ix)
1981 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1982 LEAVE_SCOPE(oldsave);
1983 return cx->blk_loop.redo_op;
1987 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1991 static char too_deep[] = "Target of goto is too deeply nested";
1995 if (o->op_type == OP_LEAVE ||
1996 o->op_type == OP_SCOPE ||
1997 o->op_type == OP_LEAVELOOP ||
1998 o->op_type == OP_LEAVETRY)
2000 *ops++ = cUNOPo->op_first;
2005 if (o->op_flags & OPf_KIDS) {
2007 /* First try all the kids at this level, since that's likeliest. */
2008 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2009 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2010 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2013 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2014 if (kid == PL_lastgotoprobe)
2016 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2018 (ops[-1]->op_type != OP_NEXTSTATE &&
2019 ops[-1]->op_type != OP_DBSTATE)))
2021 if (o = dofindlabel(kid, label, ops, oplimit))
2031 return pp_goto(ARGS);
2040 register PERL_CONTEXT *cx;
2041 #define GOTO_DEPTH 64
2042 OP *enterops[GOTO_DEPTH];
2044 int do_dump = (PL_op->op_type == OP_DUMP);
2045 static char must_have_label[] = "goto must have label";
2048 if (PL_op->op_flags & OPf_STACKED) {
2052 /* This egregious kludge implements goto &subroutine */
2053 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2055 register PERL_CONTEXT *cx;
2056 CV* cv = (CV*)SvRV(sv);
2060 int arg_was_real = 0;
2063 if (!CvROOT(cv) && !CvXSUB(cv)) {
2068 /* autoloaded stub? */
2069 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2071 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2072 GvNAMELEN(gv), FALSE);
2073 if (autogv && (cv = GvCV(autogv)))
2075 tmpstr = sv_newmortal();
2076 gv_efullname3(tmpstr, gv, Nullch);
2077 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2079 DIE("Goto undefined subroutine");
2082 /* First do some returnish stuff. */
2083 cxix = dopoptosub(cxstack_ix);
2085 DIE("Can't goto subroutine outside a subroutine");
2086 if (cxix < cxstack_ix)
2089 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2090 DIE("Can't goto subroutine from an eval-string");
2092 if (CxTYPE(cx) == CXt_SUB &&
2093 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2094 AV* av = cx->blk_sub.argarray;
2096 items = AvFILLp(av) + 1;
2098 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2099 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2100 PL_stack_sp += items;
2102 SvREFCNT_dec(GvAV(PL_defgv));
2103 GvAV(PL_defgv) = cx->blk_sub.savearray;
2104 #endif /* USE_THREADS */
2107 AvREAL_off(av); /* so av_clear() won't clobber elts */
2111 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2115 av = (AV*)PL_curpad[0];
2117 av = GvAV(PL_defgv);
2119 items = AvFILLp(av) + 1;
2121 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2122 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2123 PL_stack_sp += items;
2125 if (CxTYPE(cx) == CXt_SUB &&
2126 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2127 SvREFCNT_dec(cx->blk_sub.cv);
2128 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2129 LEAVE_SCOPE(oldsave);
2131 /* Now do some callish stuff. */
2134 #ifdef PERL_XSUB_OLDSTYLE
2135 if (CvOLDSTYLE(cv)) {
2136 I32 (*fp3)_((int,int,int));
2141 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2142 items = (*fp3)(CvXSUBANY(cv).any_i32,
2143 mark - PL_stack_base + 1,
2145 SP = PL_stack_base + items;
2148 #endif /* PERL_XSUB_OLDSTYLE */
2153 PL_stack_sp--; /* There is no cv arg. */
2154 /* Push a mark for the start of arglist */
2156 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2157 /* Pop the current context like a decent sub should */
2158 POPBLOCK(cx, PL_curpm);
2159 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2162 return pop_return();
2165 AV* padlist = CvPADLIST(cv);
2166 SV** svp = AvARRAY(padlist);
2167 if (CxTYPE(cx) == CXt_EVAL) {
2168 PL_in_eval = cx->blk_eval.old_in_eval;
2169 PL_eval_root = cx->blk_eval.old_eval_root;
2170 cx->cx_type = CXt_SUB;
2171 cx->blk_sub.hasargs = 0;
2173 cx->blk_sub.cv = cv;
2174 cx->blk_sub.olddepth = CvDEPTH(cv);
2176 if (CvDEPTH(cv) < 2)
2177 (void)SvREFCNT_inc(cv);
2178 else { /* save temporaries on recursion? */
2179 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2180 sub_crush_depth(cv);
2181 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2182 AV *newpad = newAV();
2183 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2184 I32 ix = AvFILLp((AV*)svp[1]);
2185 svp = AvARRAY(svp[0]);
2186 for ( ;ix > 0; ix--) {
2187 if (svp[ix] != &PL_sv_undef) {
2188 char *name = SvPVX(svp[ix]);
2189 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2192 /* outer lexical or anon code */
2193 av_store(newpad, ix,
2194 SvREFCNT_inc(oldpad[ix]) );
2196 else { /* our own lexical */
2198 av_store(newpad, ix, sv = (SV*)newAV());
2199 else if (*name == '%')
2200 av_store(newpad, ix, sv = (SV*)newHV());
2202 av_store(newpad, ix, sv = NEWSV(0,0));
2207 av_store(newpad, ix, sv = NEWSV(0,0));
2211 if (cx->blk_sub.hasargs) {
2214 av_store(newpad, 0, (SV*)av);
2215 AvFLAGS(av) = AVf_REIFY;
2217 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2218 AvFILLp(padlist) = CvDEPTH(cv);
2219 svp = AvARRAY(padlist);
2223 if (!cx->blk_sub.hasargs) {
2224 AV* av = (AV*)PL_curpad[0];
2226 items = AvFILLp(av) + 1;
2228 /* Mark is at the end of the stack. */
2230 Copy(AvARRAY(av), SP + 1, items, SV*);
2235 #endif /* USE_THREADS */
2236 SAVESPTR(PL_curpad);
2237 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2239 if (cx->blk_sub.hasargs)
2240 #endif /* USE_THREADS */
2242 AV* av = (AV*)PL_curpad[0];
2246 cx->blk_sub.savearray = GvAV(PL_defgv);
2247 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2248 #endif /* USE_THREADS */
2249 cx->blk_sub.argarray = av;
2252 if (items >= AvMAX(av) + 1) {
2254 if (AvARRAY(av) != ary) {
2255 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2256 SvPVX(av) = (char*)ary;
2258 if (items >= AvMAX(av) + 1) {
2259 AvMAX(av) = items - 1;
2260 Renew(ary,items+1,SV*);
2262 SvPVX(av) = (char*)ary;
2265 Copy(mark,AvARRAY(av),items,SV*);
2266 AvFILLp(av) = items - 1;
2267 /* preserve @_ nature */
2278 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2280 * We do not care about using sv to call CV;
2281 * it's for informational purposes only.
2283 SV *sv = GvSV(PL_DBsub);
2286 if (PERLDB_SUB_NN) {
2287 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2290 gv_efullname3(sv, CvGV(cv), Nullch);
2293 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2294 PUSHMARK( PL_stack_sp );
2295 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2299 RETURNOP(CvSTART(cv));
2303 label = SvPV(sv,n_a);
2304 if (!(do_dump || *label))
2305 DIE(must_have_label);
2308 else if (PL_op->op_flags & OPf_SPECIAL) {
2310 DIE(must_have_label);
2313 label = cPVOP->op_pv;
2315 if (label && *label) {
2320 PL_lastgotoprobe = 0;
2322 for (ix = cxstack_ix; ix >= 0; ix--) {
2324 switch (CxTYPE(cx)) {
2326 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2329 gotoprobe = cx->blk_oldcop->op_sibling;
2335 gotoprobe = cx->blk_oldcop->op_sibling;
2337 gotoprobe = PL_main_root;
2340 if (CvDEPTH(cx->blk_sub.cv)) {
2341 gotoprobe = CvROOT(cx->blk_sub.cv);
2346 DIE("Can't \"goto\" outside a block");
2350 gotoprobe = PL_main_root;
2353 retop = dofindlabel(gotoprobe, label,
2354 enterops, enterops + GOTO_DEPTH);
2357 PL_lastgotoprobe = gotoprobe;
2360 DIE("Can't find label %s", label);
2362 /* pop unwanted frames */
2364 if (ix < cxstack_ix) {
2371 oldsave = PL_scopestack[PL_scopestack_ix];
2372 LEAVE_SCOPE(oldsave);
2375 /* push wanted frames */
2377 if (*enterops && enterops[1]) {
2379 for (ix = 1; enterops[ix]; ix++) {
2380 PL_op = enterops[ix];
2381 /* Eventually we may want to stack the needed arguments
2382 * for each op. For now, we punt on the hard ones. */
2383 if (PL_op->op_type == OP_ENTERITER)
2384 DIE("Can't \"goto\" into the middle of a foreach loop",
2386 (CALLOP->op_ppaddr)(ARGS);
2394 if (!retop) retop = PL_main_start;
2396 PL_restartop = retop;
2397 PL_do_undump = TRUE;
2401 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2402 PL_do_undump = FALSE;
2418 if (anum == 1 && VMSISH_EXIT)
2423 PUSHs(&PL_sv_undef);
2431 double value = SvNVx(GvSV(cCOP->cop_gv));
2432 register I32 match = I_32(value);
2435 if (((double)match) > value)
2436 --match; /* was fractional--truncate other way */
2438 match -= cCOP->uop.scop.scop_offset;
2441 else if (match > cCOP->uop.scop.scop_max)
2442 match = cCOP->uop.scop.scop_max;
2443 PL_op = cCOP->uop.scop.scop_next[match];
2453 PL_op = PL_op->op_next; /* can't assume anything */
2456 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2457 match -= cCOP->uop.scop.scop_offset;
2460 else if (match > cCOP->uop.scop.scop_max)
2461 match = cCOP->uop.scop.scop_max;
2462 PL_op = cCOP->uop.scop.scop_next[match];
2471 save_lines(AV *array, SV *sv)
2473 register char *s = SvPVX(sv);
2474 register char *send = SvPVX(sv) + SvCUR(sv);
2476 register I32 line = 1;
2478 while (s && s < send) {
2479 SV *tmpstr = NEWSV(85,0);
2481 sv_upgrade(tmpstr, SVt_PVMG);
2482 t = strchr(s, '\n');
2488 sv_setpvn(tmpstr, s, t - s);
2489 av_store(array, line++, tmpstr);
2504 assert(CATCH_GET == TRUE);
2505 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2509 default: /* topmost level handles it */
2518 PL_op = PL_restartop;
2531 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2532 /* sv Text to convert to OP tree. */
2533 /* startop op_free() this to undo. */
2534 /* code Short string id of the caller. */
2536 dSP; /* Make POPBLOCK work. */
2539 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2542 OP *oop = PL_op, *rop;
2543 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2549 /* switch to eval mode */
2551 if (PL_curcop == &PL_compiling) {
2552 SAVESPTR(PL_compiling.cop_stash);
2553 PL_compiling.cop_stash = PL_curstash;
2555 SAVESPTR(PL_compiling.cop_filegv);
2556 SAVEI16(PL_compiling.cop_line);
2557 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2558 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2559 PL_compiling.cop_line = 1;
2560 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2561 deleting the eval's FILEGV from the stash before gv_check() runs
2562 (i.e. before run-time proper). To work around the coredump that
2563 ensues, we always turn GvMULTI_on for any globals that were
2564 introduced within evals. See force_ident(). GSAR 96-10-12 */
2565 safestr = savepv(tmpbuf);
2566 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2568 #ifdef OP_IN_REGISTER
2576 PL_op->op_type = OP_ENTEREVAL;
2577 PL_op->op_flags = 0; /* Avoid uninit warning. */
2578 PUSHBLOCK(cx, CXt_EVAL, SP);
2579 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2580 rop = doeval(G_SCALAR, startop);
2581 POPBLOCK(cx,PL_curpm);
2584 (*startop)->op_type = OP_NULL;
2585 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2587 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2589 if (PL_curcop == &PL_compiling)
2590 PL_compiling.op_private = PL_hints;
2591 #ifdef OP_IN_REGISTER
2597 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2599 doeval(int gimme, OP** startop)
2612 /* set up a scratch pad */
2615 SAVESPTR(PL_curpad);
2616 SAVESPTR(PL_comppad);
2617 SAVESPTR(PL_comppad_name);
2618 SAVEI32(PL_comppad_name_fill);
2619 SAVEI32(PL_min_intro_pending);
2620 SAVEI32(PL_max_intro_pending);
2623 for (i = cxstack_ix - 1; i >= 0; i--) {
2624 PERL_CONTEXT *cx = &cxstack[i];
2625 if (CxTYPE(cx) == CXt_EVAL)
2627 else if (CxTYPE(cx) == CXt_SUB) {
2628 caller = cx->blk_sub.cv;
2633 SAVESPTR(PL_compcv);
2634 PL_compcv = (CV*)NEWSV(1104,0);
2635 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2636 CvEVAL_on(PL_compcv);
2638 CvOWNER(PL_compcv) = 0;
2639 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2640 MUTEX_INIT(CvMUTEXP(PL_compcv));
2641 #endif /* USE_THREADS */
2643 PL_comppad = newAV();
2644 av_push(PL_comppad, Nullsv);
2645 PL_curpad = AvARRAY(PL_comppad);
2646 PL_comppad_name = newAV();
2647 PL_comppad_name_fill = 0;
2648 PL_min_intro_pending = 0;
2651 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2652 PL_curpad[0] = (SV*)newAV();
2653 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2654 #endif /* USE_THREADS */
2656 comppadlist = newAV();
2657 AvREAL_off(comppadlist);
2658 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2659 av_store(comppadlist, 1, (SV*)PL_comppad);
2660 CvPADLIST(PL_compcv) = comppadlist;
2662 if (!saveop || saveop->op_type != OP_REQUIRE)
2663 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2665 SAVEFREESV(PL_compcv);
2667 /* make sure we compile in the right package */
2669 newstash = PL_curcop->cop_stash;
2670 if (PL_curstash != newstash) {
2671 SAVESPTR(PL_curstash);
2672 PL_curstash = newstash;
2674 SAVESPTR(PL_beginav);
2675 PL_beginav = newAV();
2676 SAVEFREESV(PL_beginav);
2678 /* try to compile it */
2680 PL_eval_root = Nullop;
2682 PL_curcop = &PL_compiling;
2683 PL_curcop->cop_arybase = 0;
2684 SvREFCNT_dec(PL_rs);
2685 PL_rs = newSVpvn("\n", 1);
2686 if (saveop && saveop->op_flags & OPf_SPECIAL)
2690 if (yyparse() || PL_error_count || !PL_eval_root) {
2694 I32 optype = 0; /* Might be reset by POPEVAL. */
2699 op_free(PL_eval_root);
2700 PL_eval_root = Nullop;
2702 SP = PL_stack_base + POPMARK; /* pop original mark */
2704 POPBLOCK(cx,PL_curpm);
2710 if (optype == OP_REQUIRE) {
2711 char* msg = SvPVx(ERRSV, n_a);
2712 DIE("%s", *msg ? msg : "Compilation failed in require");
2713 } else if (startop) {
2714 char* msg = SvPVx(ERRSV, n_a);
2716 POPBLOCK(cx,PL_curpm);
2718 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2720 SvREFCNT_dec(PL_rs);
2721 PL_rs = SvREFCNT_inc(PL_nrs);
2723 MUTEX_LOCK(&PL_eval_mutex);
2725 COND_SIGNAL(&PL_eval_cond);
2726 MUTEX_UNLOCK(&PL_eval_mutex);
2727 #endif /* USE_THREADS */
2730 SvREFCNT_dec(PL_rs);
2731 PL_rs = SvREFCNT_inc(PL_nrs);
2732 PL_compiling.cop_line = 0;
2734 *startop = PL_eval_root;
2735 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2736 CvOUTSIDE(PL_compcv) = Nullcv;
2738 SAVEFREEOP(PL_eval_root);
2740 scalarvoid(PL_eval_root);
2741 else if (gimme & G_ARRAY)
2744 scalar(PL_eval_root);
2746 DEBUG_x(dump_eval());
2748 /* Register with debugger: */
2749 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2750 CV *cv = perl_get_cv("DB::postponed", FALSE);
2754 XPUSHs((SV*)PL_compiling.cop_filegv);
2756 perl_call_sv((SV*)cv, G_DISCARD);
2760 /* compiled okay, so do it */
2762 CvDEPTH(PL_compcv) = 1;
2763 SP = PL_stack_base + POPMARK; /* pop original mark */
2764 PL_op = saveop; /* The caller may need it. */
2766 MUTEX_LOCK(&PL_eval_mutex);
2768 COND_SIGNAL(&PL_eval_cond);
2769 MUTEX_UNLOCK(&PL_eval_mutex);
2770 #endif /* USE_THREADS */
2772 RETURNOP(PL_eval_start);
2776 doopen(const char *name, const char *mode)
2778 STRLEN namelen = strlen(name);
2781 if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
2782 SV *pmcsv = newSVpvf("%s%c", name, 'c');
2783 char *pmc = SvPV_nolen(pmcsv);
2786 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2787 fp = PerlIO_open(name, mode);
2789 if (PerlLIO_stat(name, &pmstat) < 0 ||
2790 pmstat.st_mtime < pmcstat.st_mtime) {
2791 fp = PerlIO_open(pmc, mode);
2793 fp = PerlIO_open(name, mode);
2796 SvREFCNT_dec(pmcsv);
2798 fp = PerlIO_open(name, mode);
2807 register PERL_CONTEXT *cx;
2812 SV *namesv = Nullsv;
2814 I32 gimme = G_SCALAR;
2815 PerlIO *tryrsfp = 0;
2819 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2820 SET_NUMERIC_STANDARD();
2821 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2822 DIE("Perl %s required--this is only version %s, stopped",
2823 SvPV(sv,n_a),PL_patchlevel);
2826 name = SvPV(sv, len);
2827 if (!(name && len > 0 && *name))
2828 DIE("Null filename used");
2829 TAINT_PROPER("require");
2830 if (PL_op->op_type == OP_REQUIRE &&
2831 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2832 *svp != &PL_sv_undef)
2835 /* prepare to compile file */
2840 (name[1] == '.' && name[2] == '/')))
2842 || (name[0] && name[1] == ':')
2845 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2848 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2849 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2854 tryrsfp = doopen(name,PERL_SCRIPT_MODE);
2857 AV *ar = GvAVn(PL_incgv);
2861 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2864 namesv = NEWSV(806, 0);
2865 for (i = 0; i <= AvFILL(ar); i++) {
2866 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2869 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2871 sv_setpv(namesv, unixdir);
2872 sv_catpv(namesv, unixname);
2874 sv_setpvf(namesv, "%s/%s", dir, name);
2876 TAINT_PROPER("require");
2877 tryname = SvPVX(namesv);
2878 tryrsfp = doopen(tryname, PERL_SCRIPT_MODE);
2880 if (tryname[0] == '.' && tryname[1] == '/')
2887 SAVESPTR(PL_compiling.cop_filegv);
2888 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2889 SvREFCNT_dec(namesv);
2891 if (PL_op->op_type == OP_REQUIRE) {
2892 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2893 SV *dirmsgsv = NEWSV(0, 0);
2894 AV *ar = GvAVn(PL_incgv);
2896 if (instr(SvPVX(msg), ".h "))
2897 sv_catpv(msg, " (change .h to .ph maybe?)");
2898 if (instr(SvPVX(msg), ".ph "))
2899 sv_catpv(msg, " (did you run h2ph?)");
2900 sv_catpv(msg, " (@INC contains:");
2901 for (i = 0; i <= AvFILL(ar); i++) {
2902 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2903 sv_setpvf(dirmsgsv, " %s", dir);
2904 sv_catsv(msg, dirmsgsv);
2906 sv_catpvn(msg, ")", 1);
2907 SvREFCNT_dec(dirmsgsv);
2914 SETERRNO(0, SS$_NORMAL);
2916 /* Assume success here to prevent recursive requirement. */
2917 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2918 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2922 lex_start(sv_2mortal(newSVpvn("",0)));
2923 SAVEGENERICSV(PL_rsfp_filters);
2924 PL_rsfp_filters = Nullav;
2927 name = savepv(name);
2931 SAVEPPTR(PL_compiling.cop_warnings);
2932 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2935 /* switch to eval mode */
2937 push_return(PL_op->op_next);
2938 PUSHBLOCK(cx, CXt_EVAL, SP);
2939 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2941 SAVEI16(PL_compiling.cop_line);
2942 PL_compiling.cop_line = 0;
2946 MUTEX_LOCK(&PL_eval_mutex);
2947 if (PL_eval_owner && PL_eval_owner != thr)
2948 while (PL_eval_owner)
2949 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2950 PL_eval_owner = thr;
2951 MUTEX_UNLOCK(&PL_eval_mutex);
2952 #endif /* USE_THREADS */
2953 return DOCATCH(doeval(G_SCALAR, NULL));
2958 return pp_require(ARGS);
2964 register PERL_CONTEXT *cx;
2966 I32 gimme = GIMME_V, was = PL_sub_generation;
2967 char tmpbuf[TYPE_DIGITS(long) + 12];
2972 if (!SvPV(sv,len) || !len)
2974 TAINT_PROPER("eval");
2980 /* switch to eval mode */
2982 SAVESPTR(PL_compiling.cop_filegv);
2983 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2984 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2985 PL_compiling.cop_line = 1;
2986 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2987 deleting the eval's FILEGV from the stash before gv_check() runs
2988 (i.e. before run-time proper). To work around the coredump that
2989 ensues, we always turn GvMULTI_on for any globals that were
2990 introduced within evals. See force_ident(). GSAR 96-10-12 */
2991 safestr = savepv(tmpbuf);
2992 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2994 PL_hints = PL_op->op_targ;
2995 SAVEPPTR(PL_compiling.cop_warnings);
2996 if (PL_compiling.cop_warnings != WARN_ALL
2997 && PL_compiling.cop_warnings != WARN_NONE){
2998 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2999 SAVEFREESV(PL_compiling.cop_warnings) ;
3002 push_return(PL_op->op_next);
3003 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3004 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3006 /* prepare to compile string */
3008 if (PERLDB_LINE && PL_curstash != PL_debstash)
3009 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3012 MUTEX_LOCK(&PL_eval_mutex);
3013 if (PL_eval_owner && PL_eval_owner != thr)
3014 while (PL_eval_owner)
3015 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3016 PL_eval_owner = thr;
3017 MUTEX_UNLOCK(&PL_eval_mutex);
3018 #endif /* USE_THREADS */
3019 ret = doeval(gimme, NULL);
3020 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3021 && ret != PL_op->op_next) { /* Successive compilation. */
3022 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3024 return DOCATCH(ret);
3034 register PERL_CONTEXT *cx;
3036 U8 save_flags = PL_op -> op_flags;
3041 retop = pop_return();
3044 if (gimme == G_VOID)
3046 else if (gimme == G_SCALAR) {
3049 if (SvFLAGS(TOPs) & SVs_TEMP)
3052 *MARK = sv_mortalcopy(TOPs);
3056 *MARK = &PL_sv_undef;
3060 /* in case LEAVE wipes old return values */
3061 for (mark = newsp + 1; mark <= SP; mark++) {
3062 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3063 *mark = sv_mortalcopy(*mark);
3064 TAINT_NOT; /* Each item is independent */
3068 PL_curpm = newpm; /* Don't pop $1 et al till now */
3071 * Closures mentioned at top level of eval cannot be referenced
3072 * again, and their presence indirectly causes a memory leak.
3073 * (Note that the fact that compcv and friends are still set here
3074 * is, AFAIK, an accident.) --Chip
3076 if (AvFILLp(PL_comppad_name) >= 0) {
3077 SV **svp = AvARRAY(PL_comppad_name);
3079 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3081 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3083 svp[ix] = &PL_sv_undef;
3087 SvREFCNT_dec(CvOUTSIDE(sv));
3088 CvOUTSIDE(sv) = Nullcv;
3101 assert(CvDEPTH(PL_compcv) == 1);
3103 CvDEPTH(PL_compcv) = 0;
3106 if (optype == OP_REQUIRE &&
3107 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3109 /* Unassume the success we assumed earlier. */
3110 char *name = cx->blk_eval.old_name;
3111 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3112 retop = die("%s did not return a true value", name);
3113 /* die_where() did LEAVE, or we won't be here */
3117 if (!(save_flags & OPf_SPECIAL))
3127 register PERL_CONTEXT *cx;
3128 I32 gimme = GIMME_V;
3133 push_return(cLOGOP->op_other->op_next);
3134 PUSHBLOCK(cx, CXt_EVAL, SP);
3136 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3141 return DOCATCH(PL_op->op_next);
3151 register PERL_CONTEXT *cx;
3159 if (gimme == G_VOID)
3161 else if (gimme == G_SCALAR) {
3164 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3167 *MARK = sv_mortalcopy(TOPs);
3171 *MARK = &PL_sv_undef;
3176 /* in case LEAVE wipes old return values */
3177 for (mark = newsp + 1; mark <= SP; mark++) {
3178 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3179 *mark = sv_mortalcopy(*mark);
3180 TAINT_NOT; /* Each item is independent */
3184 PL_curpm = newpm; /* Don't pop $1 et al till now */
3195 register char *s = SvPV_force(sv, len);
3196 register char *send = s + len;
3197 register char *base;
3198 register I32 skipspaces = 0;
3201 bool postspace = FALSE;
3209 croak("Null picture in formline");
3211 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3216 *fpc++ = FF_LINEMARK;
3217 noblank = repeat = FALSE;
3235 case ' ': case '\t':
3246 *fpc++ = FF_LITERAL;
3254 *fpc++ = skipspaces;
3258 *fpc++ = FF_NEWLINE;
3262 arg = fpc - linepc + 1;
3269 *fpc++ = FF_LINEMARK;
3270 noblank = repeat = FALSE;
3279 ischop = s[-1] == '^';
3285 arg = (s - base) - 1;
3287 *fpc++ = FF_LITERAL;
3296 *fpc++ = FF_LINEGLOB;
3298 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3299 arg = ischop ? 512 : 0;
3309 arg |= 256 + (s - f);
3311 *fpc++ = s - base; /* fieldsize for FETCH */
3312 *fpc++ = FF_DECIMAL;
3317 bool ismore = FALSE;
3320 while (*++s == '>') ;
3321 prespace = FF_SPACE;
3323 else if (*s == '|') {
3324 while (*++s == '|') ;
3325 prespace = FF_HALFSPACE;
3330 while (*++s == '<') ;
3333 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3337 *fpc++ = s - base; /* fieldsize for FETCH */
3339 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3357 { /* need to jump to the next word */
3359 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3360 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3361 s = SvPVX(sv) + SvCUR(sv) + z;
3363 Copy(fops, s, arg, U16);
3365 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3370 * The rest of this file was derived from source code contributed
3373 * NOTE: this code was derived from Tom Horsley's qsort replacement
3374 * and should not be confused with the original code.
3377 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3379 Permission granted to distribute under the same terms as perl which are
3382 This program is free software; you can redistribute it and/or modify
3383 it under the terms of either:
3385 a) the GNU General Public License as published by the Free
3386 Software Foundation; either version 1, or (at your option) any
3389 b) the "Artistic License" which comes with this Kit.
3391 Details on the perl license can be found in the perl source code which
3392 may be located via the www.perl.com web page.
3394 This is the most wonderfulest possible qsort I can come up with (and
3395 still be mostly portable) My (limited) tests indicate it consistently
3396 does about 20% fewer calls to compare than does the qsort in the Visual
3397 C++ library, other vendors may vary.
3399 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3400 others I invented myself (or more likely re-invented since they seemed
3401 pretty obvious once I watched the algorithm operate for a while).
3403 Most of this code was written while watching the Marlins sweep the Giants
3404 in the 1997 National League Playoffs - no Braves fans allowed to use this
3405 code (just kidding :-).
3407 I realize that if I wanted to be true to the perl tradition, the only
3408 comment in this file would be something like:
3410 ...they shuffled back towards the rear of the line. 'No, not at the
3411 rear!' the slave-driver shouted. 'Three files up. And stay there...
3413 However, I really needed to violate that tradition just so I could keep
3414 track of what happens myself, not to mention some poor fool trying to
3415 understand this years from now :-).
3418 /* ********************************************************** Configuration */
3420 #ifndef QSORT_ORDER_GUESS
3421 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3424 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3425 future processing - a good max upper bound is log base 2 of memory size
3426 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3427 safely be smaller than that since the program is taking up some space and
3428 most operating systems only let you grab some subset of contiguous
3429 memory (not to mention that you are normally sorting data larger than
3430 1 byte element size :-).
3432 #ifndef QSORT_MAX_STACK
3433 #define QSORT_MAX_STACK 32
3436 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3437 Anything bigger and we use qsort. If you make this too small, the qsort
3438 will probably break (or become less efficient), because it doesn't expect
3439 the middle element of a partition to be the same as the right or left -
3440 you have been warned).
3442 #ifndef QSORT_BREAK_EVEN
3443 #define QSORT_BREAK_EVEN 6
3446 /* ************************************************************* Data Types */
3448 /* hold left and right index values of a partition waiting to be sorted (the
3449 partition includes both left and right - right is NOT one past the end or
3450 anything like that).
3452 struct partition_stack_entry {
3455 #ifdef QSORT_ORDER_GUESS
3456 int qsort_break_even;
3460 /* ******************************************************* Shorthand Macros */
3462 /* Note that these macros will be used from inside the qsort function where
3463 we happen to know that the variable 'elt_size' contains the size of an
3464 array element and the variable 'temp' points to enough space to hold a
3465 temp element and the variable 'array' points to the array being sorted
3466 and 'compare' is the pointer to the compare routine.
3468 Also note that there are very many highly architecture specific ways
3469 these might be sped up, but this is simply the most generally portable
3470 code I could think of.
3473 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3476 #define qsort_cmp(elt1, elt2) \
3477 ((this->*compare)(array[elt1], array[elt2]))
3479 #define qsort_cmp(elt1, elt2) \
3480 ((*compare)(array[elt1], array[elt2]))
3483 #ifdef QSORT_ORDER_GUESS
3484 #define QSORT_NOTICE_SWAP swapped++;
3486 #define QSORT_NOTICE_SWAP
3489 /* swaps contents of array elements elt1, elt2.
3491 #define qsort_swap(elt1, elt2) \
3494 temp = array[elt1]; \
3495 array[elt1] = array[elt2]; \
3496 array[elt2] = temp; \
3499 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3500 elt3 and elt3 gets elt1.
3502 #define qsort_rotate(elt1, elt2, elt3) \
3505 temp = array[elt1]; \
3506 array[elt1] = array[elt2]; \
3507 array[elt2] = array[elt3]; \
3508 array[elt3] = temp; \
3511 /* ************************************************************ Debug stuff */
3518 return; /* good place to set a breakpoint */
3521 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3524 doqsort_all_asserts(
3528 int (*compare)(const void * elt1, const void * elt2),
3529 int pc_left, int pc_right, int u_left, int u_right)
3533 qsort_assert(pc_left <= pc_right);
3534 qsort_assert(u_right < pc_left);
3535 qsort_assert(pc_right < u_left);
3536 for (i = u_right + 1; i < pc_left; ++i) {
3537 qsort_assert(qsort_cmp(i, pc_left) < 0);
3539 for (i = pc_left; i < pc_right; ++i) {
3540 qsort_assert(qsort_cmp(i, pc_right) == 0);
3542 for (i = pc_right + 1; i < u_left; ++i) {
3543 qsort_assert(qsort_cmp(pc_right, i) < 0);
3547 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3548 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3549 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3553 #define qsort_assert(t) ((void)0)
3555 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3559 /* ****************************************************************** qsort */
3563 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3568 I32 (*compare)(SV *a, SV *b))
3573 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3574 int next_stack_entry = 0;
3578 #ifdef QSORT_ORDER_GUESS
3579 int qsort_break_even;
3583 /* Make sure we actually have work to do.
3585 if (num_elts <= 1) {
3589 /* Setup the initial partition definition and fall into the sorting loop
3592 part_right = (int)(num_elts - 1);
3593 #ifdef QSORT_ORDER_GUESS
3594 qsort_break_even = QSORT_BREAK_EVEN;
3596 #define qsort_break_even QSORT_BREAK_EVEN
3599 if ((part_right - part_left) >= qsort_break_even) {
3600 /* OK, this is gonna get hairy, so lets try to document all the
3601 concepts and abbreviations and variables and what they keep
3604 pc: pivot chunk - the set of array elements we accumulate in the
3605 middle of the partition, all equal in value to the original
3606 pivot element selected. The pc is defined by:
3608 pc_left - the leftmost array index of the pc
3609 pc_right - the rightmost array index of the pc
3611 we start with pc_left == pc_right and only one element
3612 in the pivot chunk (but it can grow during the scan).
3614 u: uncompared elements - the set of elements in the partition
3615 we have not yet compared to the pivot value. There are two
3616 uncompared sets during the scan - one to the left of the pc
3617 and one to the right.
3619 u_right - the rightmost index of the left side's uncompared set
3620 u_left - the leftmost index of the right side's uncompared set
3622 The leftmost index of the left sides's uncompared set
3623 doesn't need its own variable because it is always defined
3624 by the leftmost edge of the whole partition (part_left). The
3625 same goes for the rightmost edge of the right partition
3628 We know there are no uncompared elements on the left once we
3629 get u_right < part_left and no uncompared elements on the
3630 right once u_left > part_right. When both these conditions
3631 are met, we have completed the scan of the partition.
3633 Any elements which are between the pivot chunk and the
3634 uncompared elements should be less than the pivot value on
3635 the left side and greater than the pivot value on the right
3636 side (in fact, the goal of the whole algorithm is to arrange
3637 for that to be true and make the groups of less-than and
3638 greater-then elements into new partitions to sort again).
3640 As you marvel at the complexity of the code and wonder why it
3641 has to be so confusing. Consider some of the things this level
3642 of confusion brings:
3644 Once I do a compare, I squeeze every ounce of juice out of it. I
3645 never do compare calls I don't have to do, and I certainly never
3648 I also never swap any elements unless I can prove there is a
3649 good reason. Many sort algorithms will swap a known value with
3650 an uncompared value just to get things in the right place (or
3651 avoid complexity :-), but that uncompared value, once it gets
3652 compared, may then have to be swapped again. A lot of the
3653 complexity of this code is due to the fact that it never swaps
3654 anything except compared values, and it only swaps them when the
3655 compare shows they are out of position.
3657 int pc_left, pc_right;
3658 int u_right, u_left;
3662 pc_left = ((part_left + part_right) / 2);
3664 u_right = pc_left - 1;
3665 u_left = pc_right + 1;
3667 /* Qsort works best when the pivot value is also the median value
3668 in the partition (unfortunately you can't find the median value
3669 without first sorting :-), so to give the algorithm a helping
3670 hand, we pick 3 elements and sort them and use the median value
3671 of that tiny set as the pivot value.
3673 Some versions of qsort like to use the left middle and right as
3674 the 3 elements to sort so they can insure the ends of the
3675 partition will contain values which will stop the scan in the
3676 compare loop, but when you have to call an arbitrarily complex
3677 routine to do a compare, its really better to just keep track of
3678 array index values to know when you hit the edge of the
3679 partition and avoid the extra compare. An even better reason to
3680 avoid using a compare call is the fact that you can drop off the
3681 edge of the array if someone foolishly provides you with an
3682 unstable compare function that doesn't always provide consistent
3685 So, since it is simpler for us to compare the three adjacent
3686 elements in the middle of the partition, those are the ones we
3687 pick here (conveniently pointed at by u_right, pc_left, and
3688 u_left). The values of the left, center, and right elements
3689 are refered to as l c and r in the following comments.
3692 #ifdef QSORT_ORDER_GUESS
3695 s = qsort_cmp(u_right, pc_left);
3698 s = qsort_cmp(pc_left, u_left);
3699 /* if l < c, c < r - already in order - nothing to do */
3701 /* l < c, c == r - already in order, pc grows */
3703 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3705 /* l < c, c > r - need to know more */
3706 s = qsort_cmp(u_right, u_left);
3708 /* l < c, c > r, l < r - swap c & r to get ordered */
3709 qsort_swap(pc_left, u_left);
3710 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3711 } else if (s == 0) {
3712 /* l < c, c > r, l == r - swap c&r, grow pc */
3713 qsort_swap(pc_left, u_left);
3715 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3717 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3718 qsort_rotate(pc_left, u_right, u_left);
3719 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3722 } else if (s == 0) {
3724 s = qsort_cmp(pc_left, u_left);
3726 /* l == c, c < r - already in order, grow pc */
3728 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3729 } else if (s == 0) {
3730 /* l == c, c == r - already in order, grow pc both ways */
3733 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3735 /* l == c, c > r - swap l & r, grow pc */
3736 qsort_swap(u_right, u_left);
3738 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3742 s = qsort_cmp(pc_left, u_left);
3744 /* l > c, c < r - need to know more */
3745 s = qsort_cmp(u_right, u_left);
3747 /* l > c, c < r, l < r - swap l & c to get ordered */
3748 qsort_swap(u_right, pc_left);
3749 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3750 } else if (s == 0) {
3751 /* l > c, c < r, l == r - swap l & c, grow pc */
3752 qsort_swap(u_right, pc_left);
3754 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3756 /* l > c, c < r, l > r - rotate lcr into crl to order */
3757 qsort_rotate(u_right, pc_left, u_left);
3758 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3760 } else if (s == 0) {
3761 /* l > c, c == r - swap ends, grow pc */
3762 qsort_swap(u_right, u_left);
3764 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3766 /* l > c, c > r - swap ends to get in order */
3767 qsort_swap(u_right, u_left);
3768 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3771 /* We now know the 3 middle elements have been compared and
3772 arranged in the desired order, so we can shrink the uncompared
3777 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3779 /* The above massive nested if was the simple part :-). We now have
3780 the middle 3 elements ordered and we need to scan through the
3781 uncompared sets on either side, swapping elements that are on
3782 the wrong side or simply shuffling equal elements around to get
3783 all equal elements into the pivot chunk.
3787 int still_work_on_left;
3788 int still_work_on_right;
3790 /* Scan the uncompared values on the left. If I find a value
3791 equal to the pivot value, move it over so it is adjacent to
3792 the pivot chunk and expand the pivot chunk. If I find a value
3793 less than the pivot value, then just leave it - its already
3794 on the correct side of the partition. If I find a greater
3795 value, then stop the scan.
3797 while (still_work_on_left = (u_right >= part_left)) {
3798 s = qsort_cmp(u_right, pc_left);
3801 } else if (s == 0) {
3803 if (pc_left != u_right) {
3804 qsort_swap(u_right, pc_left);
3810 qsort_assert(u_right < pc_left);
3811 qsort_assert(pc_left <= pc_right);
3812 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3813 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3816 /* Do a mirror image scan of uncompared values on the right
3818 while (still_work_on_right = (u_left <= part_right)) {
3819 s = qsort_cmp(pc_right, u_left);
3822 } else if (s == 0) {
3824 if (pc_right != u_left) {
3825 qsort_swap(pc_right, u_left);
3831 qsort_assert(u_left > pc_right);
3832 qsort_assert(pc_left <= pc_right);
3833 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3834 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3837 if (still_work_on_left) {
3838 /* I know I have a value on the left side which needs to be
3839 on the right side, but I need to know more to decide
3840 exactly the best thing to do with it.
3842 if (still_work_on_right) {
3843 /* I know I have values on both side which are out of
3844 position. This is a big win because I kill two birds
3845 with one swap (so to speak). I can advance the
3846 uncompared pointers on both sides after swapping both
3847 of them into the right place.
3849 qsort_swap(u_right, u_left);
3852 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3854 /* I have an out of position value on the left, but the
3855 right is fully scanned, so I "slide" the pivot chunk
3856 and any less-than values left one to make room for the
3857 greater value over on the right. If the out of position
3858 value is immediately adjacent to the pivot chunk (there
3859 are no less-than values), I can do that with a swap,
3860 otherwise, I have to rotate one of the less than values
3861 into the former position of the out of position value
3862 and the right end of the pivot chunk into the left end
3866 if (pc_left == u_right) {
3867 qsort_swap(u_right, pc_right);
3868 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3870 qsort_rotate(u_right, pc_left, pc_right);
3871 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3876 } else if (still_work_on_right) {
3877 /* Mirror image of complex case above: I have an out of
3878 position value on the right, but the left is fully
3879 scanned, so I need to shuffle things around to make room
3880 for the right value on the left.
3883 if (pc_right == u_left) {
3884 qsort_swap(u_left, pc_left);
3885 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3887 qsort_rotate(pc_right, pc_left, u_left);
3888 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3893 /* No more scanning required on either side of partition,
3894 break out of loop and figure out next set of partitions
3900 /* The elements in the pivot chunk are now in the right place. They
3901 will never move or be compared again. All I have to do is decide
3902 what to do with the stuff to the left and right of the pivot
3905 Notes on the QSORT_ORDER_GUESS ifdef code:
3907 1. If I just built these partitions without swapping any (or
3908 very many) elements, there is a chance that the elements are
3909 already ordered properly (being properly ordered will
3910 certainly result in no swapping, but the converse can't be
3913 2. A (properly written) insertion sort will run faster on
3914 already ordered data than qsort will.
3916 3. Perhaps there is some way to make a good guess about
3917 switching to an insertion sort earlier than partition size 6
3918 (for instance - we could save the partition size on the stack
3919 and increase the size each time we find we didn't swap, thus
3920 switching to insertion sort earlier for partitions with a
3921 history of not swapping).
3923 4. Naturally, if I just switch right away, it will make
3924 artificial benchmarks with pure ascending (or descending)
3925 data look really good, but is that a good reason in general?
3929 #ifdef QSORT_ORDER_GUESS
3931 #if QSORT_ORDER_GUESS == 1
3932 qsort_break_even = (part_right - part_left) + 1;
3934 #if QSORT_ORDER_GUESS == 2
3935 qsort_break_even *= 2;
3937 #if QSORT_ORDER_GUESS == 3
3938 int prev_break = qsort_break_even;
3939 qsort_break_even *= qsort_break_even;
3940 if (qsort_break_even < prev_break) {
3941 qsort_break_even = (part_right - part_left) + 1;
3945 qsort_break_even = QSORT_BREAK_EVEN;
3949 if (part_left < pc_left) {
3950 /* There are elements on the left which need more processing.
3951 Check the right as well before deciding what to do.
3953 if (pc_right < part_right) {
3954 /* We have two partitions to be sorted. Stack the biggest one
3955 and process the smallest one on the next iteration. This
3956 minimizes the stack height by insuring that any additional
3957 stack entries must come from the smallest partition which
3958 (because it is smallest) will have the fewest
3959 opportunities to generate additional stack entries.
3961 if ((part_right - pc_right) > (pc_left - part_left)) {
3962 /* stack the right partition, process the left */
3963 partition_stack[next_stack_entry].left = pc_right + 1;
3964 partition_stack[next_stack_entry].right = part_right;
3965 #ifdef QSORT_ORDER_GUESS
3966 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3968 part_right = pc_left - 1;
3970 /* stack the left partition, process the right */
3971 partition_stack[next_stack_entry].left = part_left;
3972 partition_stack[next_stack_entry].right = pc_left - 1;
3973 #ifdef QSORT_ORDER_GUESS
3974 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3976 part_left = pc_right + 1;
3978 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3981 /* The elements on the left are the only remaining elements
3982 that need sorting, arrange for them to be processed as the
3985 part_right = pc_left - 1;
3987 } else if (pc_right < part_right) {
3988 /* There is only one chunk on the right to be sorted, make it
3989 the new partition and loop back around.
3991 part_left = pc_right + 1;
3993 /* This whole partition wound up in the pivot chunk, so
3994 we need to get a new partition off the stack.
3996 if (next_stack_entry == 0) {
3997 /* the stack is empty - we are done */
4001 part_left = partition_stack[next_stack_entry].left;
4002 part_right = partition_stack[next_stack_entry].right;
4003 #ifdef QSORT_ORDER_GUESS
4004 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4008 /* This partition is too small to fool with qsort complexity, just
4009 do an ordinary insertion sort to minimize overhead.
4012 /* Assume 1st element is in right place already, and start checking
4013 at 2nd element to see where it should be inserted.
4015 for (i = part_left + 1; i <= part_right; ++i) {
4017 /* Scan (backwards - just in case 'i' is already in right place)
4018 through the elements already sorted to see if the ith element
4019 belongs ahead of one of them.
4021 for (j = i - 1; j >= part_left; --j) {
4022 if (qsort_cmp(i, j) >= 0) {
4023 /* i belongs right after j
4030 /* Looks like we really need to move some things
4034 for (k = i - 1; k >= j; --k)
4035 array[k + 1] = array[k];
4040 /* That partition is now sorted, grab the next one, or get out
4041 of the loop if there aren't any more.
4044 if (next_stack_entry == 0) {
4045 /* the stack is empty - we are done */
4049 part_left = partition_stack[next_stack_entry].left;
4050 part_right = partition_stack[next_stack_entry].right;
4051 #ifdef QSORT_ORDER_GUESS
4052 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4057 /* Believe it or not, the array is sorted at this point! */