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 void *docatch_body _((va_list args));
33 static OP *docatch _((OP *o));
34 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
35 static void doparseform _((SV *sv));
36 static I32 dopoptoeval _((I32 startingblock));
37 static I32 dopoptolabel _((char *label));
38 static I32 dopoptoloop _((I32 startingblock));
39 static I32 dopoptosub _((I32 startingblock));
40 static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
41 static void save_lines _((AV *array, SV *sv));
42 static I32 sortcv _((SV *a, SV *b));
43 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
44 static OP *doeval _((int gimme, OP** startop));
45 static PerlIO *doopen_pmc _((const char *name, const char *mode));
46 static I32 sv_ncmp _((SV *a, SV *b));
47 static I32 sv_i_ncmp _((SV *a, SV *b));
48 static I32 amagic_ncmp _((SV *a, SV *b));
49 static I32 amagic_i_ncmp _((SV *a, SV *b));
50 static I32 amagic_cmp _((SV *str1, SV *str2));
51 static I32 amagic_cmp_locale _((SV *str1, SV *str2));
60 cxix = dopoptosub(cxstack_ix);
64 switch (cxstack[cxix].blk_gimme) {
81 /* XXXX Should store the old value to allow for tie/overload - and
82 restore in regcomp, where marked with XXXX. */
90 register PMOP *pm = (PMOP*)cLOGOP->op_other;
94 MAGIC *mg = Null(MAGIC*);
98 SV *sv = SvRV(tmpstr);
100 mg = mg_find(sv, 'r');
103 regexp *re = (regexp *)mg->mg_obj;
104 ReREFCNT_dec(pm->op_pmregexp);
105 pm->op_pmregexp = ReREFCNT_inc(re);
108 t = SvPV(tmpstr, len);
110 /* Check against the last compiled regexp. */
111 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
112 pm->op_pmregexp->prelen != len ||
113 memNE(pm->op_pmregexp->precomp, t, len))
115 if (pm->op_pmregexp) {
116 ReREFCNT_dec(pm->op_pmregexp);
117 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
119 if (PL_op->op_flags & OPf_SPECIAL)
120 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
122 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
123 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
124 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
125 inside tie/overload accessors. */
129 #ifndef INCOMPLETE_TAINTS
132 pm->op_pmdynflags |= PMdf_TAINTED;
134 pm->op_pmdynflags &= ~PMdf_TAINTED;
138 if (!pm->op_pmregexp->prelen && PL_curpm)
140 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
141 pm->op_pmflags |= PMf_WHITE;
143 if (pm->op_pmflags & PMf_KEEP) {
144 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
145 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
161 rxres_restore(&cx->sb_rxres, rx);
163 if (cx->sb_iters++) {
164 if (cx->sb_iters > cx->sb_maxiters)
165 DIE("Substitution loop");
167 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
168 cx->sb_rxtainted |= 2;
169 sv_catsv(dstr, POPs);
172 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
173 s == m, cx->sb_targ, NULL,
174 ((cx->sb_rflags & REXEC_COPY_STR)
176 : (REXEC_COPY_STR|REXEC_IGNOREPOS))))
178 SV *targ = cx->sb_targ;
179 sv_catpvn(dstr, s, cx->sb_strend - s);
181 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183 (void)SvOOK_off(targ);
184 Safefree(SvPVX(targ));
185 SvPVX(targ) = SvPVX(dstr);
186 SvCUR_set(targ, SvCUR(dstr));
187 SvLEN_set(targ, SvLEN(dstr));
191 TAINT_IF(cx->sb_rxtainted & 1);
192 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
194 (void)SvPOK_only(targ);
195 TAINT_IF(cx->sb_rxtainted);
199 LEAVE_SCOPE(cx->sb_oldsave);
201 RETURNOP(pm->op_next);
204 if (rx->subbase && rx->subbase != orig) {
207 cx->sb_orig = orig = rx->subbase;
209 cx->sb_strend = s + (cx->sb_strend - m);
211 cx->sb_m = m = rx->startp[0];
212 sv_catpvn(dstr, s, m-s);
213 cx->sb_s = rx->endp[0];
214 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
215 rxres_save(&cx->sb_rxres, rx);
216 RETURNOP(pm->op_pmreplstart);
220 rxres_save(void **rsp, REGEXP *rx)
225 if (!p || p[1] < rx->nparens) {
226 i = 6 + rx->nparens * 2;
234 *p++ = (UV)rx->subbase;
235 rx->subbase = Nullch;
239 *p++ = (UV)rx->subbeg;
240 *p++ = (UV)rx->subend;
241 for (i = 0; i <= rx->nparens; ++i) {
242 *p++ = (UV)rx->startp[i];
243 *p++ = (UV)rx->endp[i];
248 rxres_restore(void **rsp, REGEXP *rx)
253 Safefree(rx->subbase);
254 rx->subbase = (char*)(*p);
259 rx->subbeg = (char*)(*p++);
260 rx->subend = (char*)(*p++);
261 for (i = 0; i <= rx->nparens; ++i) {
262 rx->startp[i] = (char*)(*p++);
263 rx->endp[i] = (char*)(*p++);
268 rxres_free(void **rsp)
273 Safefree((char*)(*p));
281 djSP; dMARK; dORIGMARK;
282 register SV *tmpForm = *++MARK;
294 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
300 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
302 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
303 SvREADONLY_off(tmpForm);
304 doparseform(tmpForm);
307 SvPV_force(PL_formtarget, len);
308 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
310 f = SvPV(tmpForm, len);
311 /* need to jump to the next word */
312 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
321 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
322 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
323 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
324 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
325 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
327 case FF_CHECKNL: name = "CHECKNL"; break;
328 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
329 case FF_SPACE: name = "SPACE"; break;
330 case FF_HALFSPACE: name = "HALFSPACE"; break;
331 case FF_ITEM: name = "ITEM"; break;
332 case FF_CHOP: name = "CHOP"; break;
333 case FF_LINEGLOB: name = "LINEGLOB"; break;
334 case FF_NEWLINE: name = "NEWLINE"; break;
335 case FF_MORE: name = "MORE"; break;
336 case FF_LINEMARK: name = "LINEMARK"; break;
337 case FF_END: name = "END"; break;
340 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
342 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
370 if (ckWARN(WARN_SYNTAX))
371 warner(WARN_SYNTAX, "Not enough format arguments");
376 item = s = SvPV(sv, len);
379 itemsize = sv_len_utf8(sv);
380 if (itemsize != len) {
382 if (itemsize > fieldsize) {
383 itemsize = fieldsize;
384 itembytes = itemsize;
385 sv_pos_u2b(sv, &itembytes, 0);
389 send = chophere = s + itembytes;
398 sv_pos_b2u(sv, &itemsize);
402 if (itemsize > fieldsize)
403 itemsize = fieldsize;
404 send = chophere = s + itemsize;
416 item = s = SvPV(sv, len);
419 itemsize = sv_len_utf8(sv);
420 if (itemsize != len) {
422 if (itemsize <= fieldsize) {
423 send = chophere = s + itemsize;
434 itemsize = fieldsize;
435 itembytes = itemsize;
436 sv_pos_u2b(sv, &itembytes, 0);
437 send = chophere = s + itembytes;
438 while (s < send || (s == send && isSPACE(*s))) {
448 if (strchr(PL_chopset, *s))
453 itemsize = chophere - item;
454 sv_pos_b2u(sv, &itemsize);
459 if (itemsize <= fieldsize) {
460 send = chophere = s + itemsize;
471 itemsize = fieldsize;
472 send = chophere = s + itemsize;
473 while (s < send || (s == send && isSPACE(*s))) {
483 if (strchr(PL_chopset, *s))
488 itemsize = chophere - item;
493 arg = fieldsize - itemsize;
502 arg = fieldsize - itemsize;
517 switch (UTF8SKIP(s)) {
528 if ( !((*t++ = *s++) & ~31) )
536 int ch = *t++ = *s++;
539 if ( !((*t++ = *s++) & ~31) )
548 while (*s && isSPACE(*s))
555 item = s = SvPV(sv, len);
568 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
569 sv_catpvn(PL_formtarget, item, itemsize);
570 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
571 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
576 /* If the field is marked with ^ and the value is undefined,
579 if ((arg & 512) && !SvOK(sv)) {
587 /* Formats aren't yet marked for locales, so assume "yes". */
590 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
592 sprintf(t, "%*.0f", (int) fieldsize, value);
599 while (t-- > linemark && *t == ' ') ;
607 if (arg) { /* repeat until fields exhausted? */
609 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
610 lines += FmLINES(PL_formtarget);
613 if (strnEQ(linemark, linemark - arg, arg))
614 DIE("Runaway format");
616 FmLINES(PL_formtarget) = lines;
618 RETURNOP(cLISTOP->op_first);
631 while (*s && isSPACE(*s) && s < send)
635 arg = fieldsize - itemsize;
642 if (strnEQ(s," ",3)) {
643 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
654 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
655 FmLINES(PL_formtarget) += lines;
667 if (PL_stack_base + *PL_markstack_ptr == SP) {
669 if (GIMME_V == G_SCALAR)
671 RETURNOP(PL_op->op_next->op_next);
673 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
674 pp_pushmark(ARGS); /* push dst */
675 pp_pushmark(ARGS); /* push src */
676 ENTER; /* enter outer scope */
679 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
681 ENTER; /* enter inner scope */
684 src = PL_stack_base[*PL_markstack_ptr];
689 if (PL_op->op_type == OP_MAPSTART)
690 pp_pushmark(ARGS); /* push top */
691 return ((LOGOP*)PL_op->op_next)->op_other;
696 DIE("panic: mapstart"); /* uses grepstart */
702 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
708 ++PL_markstack_ptr[-1];
710 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
711 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
712 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
717 PL_markstack_ptr[-1] += shift;
718 *PL_markstack_ptr += shift;
722 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
725 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
727 LEAVE; /* exit inner scope */
730 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
734 (void)POPMARK; /* pop top */
735 LEAVE; /* exit outer scope */
736 (void)POPMARK; /* pop src */
737 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
738 (void)POPMARK; /* pop dst */
739 SP = PL_stack_base + POPMARK; /* pop original mark */
740 if (gimme == G_SCALAR) {
744 else if (gimme == G_ARRAY)
751 ENTER; /* enter inner scope */
754 src = PL_stack_base[PL_markstack_ptr[-1]];
758 RETURNOP(cLOGOP->op_other);
763 sv_ncmp (SV *a, SV *b)
765 double nv1 = SvNV(a);
766 double nv2 = SvNV(b);
767 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
770 sv_i_ncmp (SV *a, SV *b)
774 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
776 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
778 if (PL_amagic_generation) { \
779 if (SvAMAGIC(left)||SvAMAGIC(right))\
780 *svp = amagic_call(left, \
788 amagic_ncmp(register SV *a, register SV *b)
791 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
796 I32 i = SvIVX(tmpsv);
806 return sv_ncmp(a, b);
810 amagic_i_ncmp(register SV *a, register SV *b)
813 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
818 I32 i = SvIVX(tmpsv);
828 return sv_i_ncmp(a, b);
832 amagic_cmp(register SV *str1, register SV *str2)
835 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
840 I32 i = SvIVX(tmpsv);
850 return sv_cmp(str1, str2);
854 amagic_cmp_locale(register SV *str1, register SV *str2)
857 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
862 I32 i = SvIVX(tmpsv);
872 return sv_cmp_locale(str1, str2);
877 djSP; dMARK; dORIGMARK;
879 SV **myorigmark = ORIGMARK;
885 OP* nextop = PL_op->op_next;
888 if (gimme != G_ARRAY) {
894 SAVEPPTR(PL_sortcop);
895 if (PL_op->op_flags & OPf_STACKED) {
896 if (PL_op->op_flags & OPf_SPECIAL) {
897 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
898 kid = kUNOP->op_first; /* pass rv2gv */
899 kid = kUNOP->op_first; /* pass leave */
900 PL_sortcop = kid->op_next;
901 stash = PL_curcop->cop_stash;
904 cv = sv_2cv(*++MARK, &stash, &gv, 0);
905 if (!(cv && CvROOT(cv))) {
907 SV *tmpstr = sv_newmortal();
908 gv_efullname3(tmpstr, gv, Nullch);
909 if (cv && CvXSUB(cv))
910 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
911 DIE("Undefined sort subroutine \"%s\" called",
916 DIE("Xsub called in sort");
917 DIE("Undefined subroutine in sort");
919 DIE("Not a CODE reference in sort");
921 PL_sortcop = CvSTART(cv);
922 SAVESPTR(CvROOT(cv)->op_ppaddr);
923 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
926 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
931 stash = PL_curcop->cop_stash;
935 while (MARK < SP) { /* This may or may not shift down one here. */
937 if (*up = *++MARK) { /* Weed out nulls. */
939 if (!PL_sortcop && !SvPOK(*up)) {
944 (void)sv_2pv(*up, &n_a);
949 max = --up - myorigmark;
954 bool oldcatch = CATCH_GET;
960 PUSHSTACKi(PERLSI_SORT);
961 if (PL_sortstash != stash) {
962 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
963 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
964 PL_sortstash = stash;
967 SAVESPTR(GvSV(PL_firstgv));
968 SAVESPTR(GvSV(PL_secondgv));
970 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
971 if (!(PL_op->op_flags & OPf_SPECIAL)) {
972 bool hasargs = FALSE;
973 cx->cx_type = CXt_SUB;
974 cx->blk_gimme = G_SCALAR;
977 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
979 PL_sortcxix = cxstack_ix;
980 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
982 POPBLOCK(cx,PL_curpm);
990 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
991 qsortsv(ORIGMARK+1, max,
992 (PL_op->op_private & OPpSORT_NUMERIC)
993 ? ( (PL_op->op_private & OPpSORT_INTEGER)
995 ? FUNC_NAME_TO_PTR(amagic_i_ncmp)
996 : FUNC_NAME_TO_PTR(sv_i_ncmp))
998 ? FUNC_NAME_TO_PTR(amagic_ncmp)
999 : FUNC_NAME_TO_PTR(sv_ncmp)))
1000 : ( (PL_op->op_private & OPpLOCALE)
1002 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
1003 : FUNC_NAME_TO_PTR(sv_cmp_locale))
1005 ? FUNC_NAME_TO_PTR(amagic_cmp)
1006 : FUNC_NAME_TO_PTR(sv_cmp) )));
1007 if (PL_op->op_private & OPpSORT_REVERSE) {
1008 SV **p = ORIGMARK+1;
1009 SV **q = ORIGMARK+max;
1019 PL_stack_sp = ORIGMARK + max;
1027 if (GIMME == G_ARRAY)
1028 return cCONDOP->op_true;
1029 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
1036 if (GIMME == G_ARRAY) {
1037 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1041 SV *targ = PAD_SV(PL_op->op_targ);
1043 if ((PL_op->op_private & OPpFLIP_LINENUM)
1044 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1046 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1047 if (PL_op->op_flags & OPf_SPECIAL) {
1055 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1068 if (GIMME == G_ARRAY) {
1074 if (SvGMAGICAL(left))
1076 if (SvGMAGICAL(right))
1079 if (SvNIOKp(left) || !SvPOKp(left) ||
1080 (looks_like_number(left) && *SvPVX(left) != '0') )
1082 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1083 croak("Range iterator outside integer range");
1094 sv = sv_2mortal(newSViv(i++));
1099 SV *final = sv_mortalcopy(right);
1101 char *tmps = SvPV(final, len);
1103 sv = sv_mortalcopy(left);
1105 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1107 if (strEQ(SvPVX(sv),tmps))
1109 sv = sv_2mortal(newSVsv(sv));
1116 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1118 if ((PL_op->op_private & OPpFLIP_LINENUM)
1119 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1121 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1122 sv_catpv(targ, "E0");
1133 dopoptolabel(char *label)
1137 register PERL_CONTEXT *cx;
1139 for (i = cxstack_ix; i >= 0; i--) {
1141 switch (CxTYPE(cx)) {
1143 if (ckWARN(WARN_UNSAFE))
1144 warner(WARN_UNSAFE, "Exiting substitution via %s",
1145 PL_op_name[PL_op->op_type]);
1148 if (ckWARN(WARN_UNSAFE))
1149 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1150 PL_op_name[PL_op->op_type]);
1153 if (ckWARN(WARN_UNSAFE))
1154 warner(WARN_UNSAFE, "Exiting eval via %s",
1155 PL_op_name[PL_op->op_type]);
1158 if (ckWARN(WARN_UNSAFE))
1159 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1160 PL_op_name[PL_op->op_type]);
1163 if (!cx->blk_loop.label ||
1164 strNE(label, cx->blk_loop.label) ) {
1165 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1166 (long)i, cx->blk_loop.label));
1169 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1179 I32 gimme = block_gimme();
1180 return (gimme == G_VOID) ? G_SCALAR : gimme;
1189 cxix = dopoptosub(cxstack_ix);
1193 switch (cxstack[cxix].blk_gimme) {
1201 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1208 dopoptosub(I32 startingblock)
1211 return dopoptosub_at(cxstack, startingblock);
1215 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1219 register PERL_CONTEXT *cx;
1220 for (i = startingblock; i >= 0; i--) {
1222 switch (CxTYPE(cx)) {
1227 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1235 dopoptoeval(I32 startingblock)
1239 register PERL_CONTEXT *cx;
1240 for (i = startingblock; i >= 0; i--) {
1242 switch (CxTYPE(cx)) {
1246 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1254 dopoptoloop(I32 startingblock)
1258 register PERL_CONTEXT *cx;
1259 for (i = startingblock; i >= 0; i--) {
1261 switch (CxTYPE(cx)) {
1263 if (ckWARN(WARN_UNSAFE))
1264 warner(WARN_UNSAFE, "Exiting substitution via %s",
1265 PL_op_name[PL_op->op_type]);
1268 if (ckWARN(WARN_UNSAFE))
1269 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1270 PL_op_name[PL_op->op_type]);
1273 if (ckWARN(WARN_UNSAFE))
1274 warner(WARN_UNSAFE, "Exiting eval via %s",
1275 PL_op_name[PL_op->op_type]);
1278 if (ckWARN(WARN_UNSAFE))
1279 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1280 PL_op_name[PL_op->op_type]);
1283 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1294 register PERL_CONTEXT *cx;
1298 while (cxstack_ix > cxix) {
1299 cx = &cxstack[cxstack_ix];
1300 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1301 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1302 /* Note: we don't need to restore the base context info till the end. */
1303 switch (CxTYPE(cx)) {
1306 continue; /* not break */
1324 die_where(char *message, STRLEN msglen)
1330 register PERL_CONTEXT *cx;
1335 if (PL_in_eval & 4) {
1338 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1341 static char prefix[] = "\t(in cleanup) ";
1343 sv_upgrade(*svp, SVt_IV);
1344 (void)SvIOK_only(*svp);
1347 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1348 sv_catpvn(err, prefix, sizeof(prefix)-1);
1349 sv_catpvn(err, message, msglen);
1350 if (ckWARN(WARN_UNSAFE)) {
1351 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1352 warner(WARN_UNSAFE, SvPVX(err)+start);
1359 sv_setpvn(ERRSV, message, msglen);
1362 message = SvPVx(ERRSV, msglen);
1364 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1372 if (cxix < cxstack_ix)
1375 POPBLOCK(cx,PL_curpm);
1376 if (CxTYPE(cx) != CXt_EVAL) {
1377 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1378 PerlIO_write(PerlIO_stderr(), message, msglen);
1383 if (gimme == G_SCALAR)
1384 *++newsp = &PL_sv_undef;
1385 PL_stack_sp = newsp;
1389 if (optype == OP_REQUIRE) {
1390 char* msg = SvPVx(ERRSV, n_a);
1391 DIE("%s", *msg ? msg : "Compilation failed in require");
1393 return pop_return();
1397 message = SvPVx(ERRSV, msglen);
1400 /* SFIO can really mess with your errno */
1403 PerlIO_write(PerlIO_stderr(), message, msglen);
1404 (void)PerlIO_flush(PerlIO_stderr());
1417 if (SvTRUE(left) != SvTRUE(right))
1429 RETURNOP(cLOGOP->op_other);
1438 RETURNOP(cLOGOP->op_other);
1444 register I32 cxix = dopoptosub(cxstack_ix);
1445 register PERL_CONTEXT *cx;
1446 register PERL_CONTEXT *ccstack = cxstack;
1447 PERL_SI *top_si = PL_curstackinfo;
1458 /* we may be in a higher stacklevel, so dig down deeper */
1459 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1460 top_si = top_si->si_prev;
1461 ccstack = top_si->si_cxstack;
1462 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1465 if (GIMME != G_ARRAY)
1469 if (PL_DBsub && cxix >= 0 &&
1470 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1474 cxix = dopoptosub_at(ccstack, cxix - 1);
1477 cx = &ccstack[cxix];
1478 if (CxTYPE(cx) == CXt_SUB) {
1479 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1480 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1481 field below is defined for any cx. */
1482 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1483 cx = &ccstack[dbcxix];
1486 if (GIMME != G_ARRAY) {
1487 hv = cx->blk_oldcop->cop_stash;
1489 PUSHs(&PL_sv_undef);
1492 sv_setpv(TARG, HvNAME(hv));
1498 hv = cx->blk_oldcop->cop_stash;
1500 PUSHs(&PL_sv_undef);
1502 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1503 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1504 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1505 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1508 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1510 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1511 PUSHs(sv_2mortal(sv));
1512 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1515 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1516 PUSHs(sv_2mortal(newSViv(0)));
1518 gimme = (I32)cx->blk_gimme;
1519 if (gimme == G_VOID)
1520 PUSHs(&PL_sv_undef);
1522 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1523 if (CxTYPE(cx) == CXt_EVAL) {
1524 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1525 PUSHs(cx->blk_eval.cur_text);
1528 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1529 /* Require, put the name. */
1530 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1534 else if (CxTYPE(cx) == CXt_SUB &&
1535 cx->blk_sub.hasargs &&
1536 PL_curcop->cop_stash == PL_debstash)
1538 AV *ary = cx->blk_sub.argarray;
1539 int off = AvARRAY(ary) - AvALLOC(ary);
1543 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1546 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1549 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1550 av_extend(PL_dbargs, AvFILLp(ary) + off);
1551 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1552 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1558 sortcv(SV *a, SV *b)
1561 I32 oldsaveix = PL_savestack_ix;
1562 I32 oldscopeix = PL_scopestack_ix;
1564 GvSV(PL_firstgv) = a;
1565 GvSV(PL_secondgv) = b;
1566 PL_stack_sp = PL_stack_base;
1569 if (PL_stack_sp != PL_stack_base + 1)
1570 croak("Sort subroutine didn't return single value");
1571 if (!SvNIOKp(*PL_stack_sp))
1572 croak("Sort subroutine didn't return a numeric value");
1573 result = SvIV(*PL_stack_sp);
1574 while (PL_scopestack_ix > oldscopeix) {
1577 leave_scope(oldsaveix);
1591 sv_reset(tmps, PL_curcop->cop_stash);
1603 PL_curcop = (COP*)PL_op;
1604 TAINT_NOT; /* Each statement is presumed innocent */
1605 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1608 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1612 register PERL_CONTEXT *cx;
1613 I32 gimme = G_ARRAY;
1620 DIE("No DB::DB routine defined");
1622 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1634 push_return(PL_op->op_next);
1635 PUSHBLOCK(cx, CXt_SUB, SP);
1638 (void)SvREFCNT_inc(cv);
1639 SAVESPTR(PL_curpad);
1640 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1641 RETURNOP(CvSTART(cv));
1655 register PERL_CONTEXT *cx;
1656 I32 gimme = GIMME_V;
1663 if (PL_op->op_flags & OPf_SPECIAL) {
1665 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1666 SAVEGENERICSV(*svp);
1670 #endif /* USE_THREADS */
1671 if (PL_op->op_targ) {
1672 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1676 svp = &GvSV((GV*)POPs); /* symbol table variable */
1677 SAVEGENERICSV(*svp);
1683 PUSHBLOCK(cx, CXt_LOOP, SP);
1684 PUSHLOOP(cx, svp, MARK);
1685 if (PL_op->op_flags & OPf_STACKED) {
1686 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1687 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1689 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1690 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1691 if (SvNV(sv) < IV_MIN ||
1692 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1693 croak("Range iterator outside integer range");
1694 cx->blk_loop.iterix = SvIV(sv);
1695 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1698 cx->blk_loop.iterlval = newSVsv(sv);
1702 cx->blk_loop.iterary = PL_curstack;
1703 AvFILLp(PL_curstack) = SP - PL_stack_base;
1704 cx->blk_loop.iterix = MARK - PL_stack_base;
1713 register PERL_CONTEXT *cx;
1714 I32 gimme = GIMME_V;
1720 PUSHBLOCK(cx, CXt_LOOP, SP);
1721 PUSHLOOP(cx, 0, SP);
1729 register PERL_CONTEXT *cx;
1730 struct block_loop cxloop;
1738 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1741 if (gimme == G_VOID)
1743 else if (gimme == G_SCALAR) {
1745 *++newsp = sv_mortalcopy(*SP);
1747 *++newsp = &PL_sv_undef;
1751 *++newsp = sv_mortalcopy(*++mark);
1752 TAINT_NOT; /* Each item is independent */
1758 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1759 PL_curpm = newpm; /* ... and pop $1 et al */
1771 register PERL_CONTEXT *cx;
1772 struct block_sub cxsub;
1773 bool popsub2 = FALSE;
1779 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1780 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1781 if (cxstack_ix > PL_sortcxix)
1782 dounwind(PL_sortcxix);
1783 AvARRAY(PL_curstack)[1] = *SP;
1784 PL_stack_sp = PL_stack_base + 1;
1789 cxix = dopoptosub(cxstack_ix);
1791 DIE("Can't return outside a subroutine");
1792 if (cxix < cxstack_ix)
1796 switch (CxTYPE(cx)) {
1798 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1803 if (optype == OP_REQUIRE &&
1804 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1806 /* Unassume the success we assumed earlier. */
1807 char *name = cx->blk_eval.old_name;
1808 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1809 DIE("%s did not return a true value", name);
1813 DIE("panic: return");
1817 if (gimme == G_SCALAR) {
1820 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1822 *++newsp = SvREFCNT_inc(*SP);
1827 *++newsp = sv_mortalcopy(*SP);
1830 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1832 *++newsp = sv_mortalcopy(*SP);
1834 *++newsp = &PL_sv_undef;
1836 else if (gimme == G_ARRAY) {
1837 while (++MARK <= SP) {
1838 *++newsp = (popsub2 && SvTEMP(*MARK))
1839 ? *MARK : sv_mortalcopy(*MARK);
1840 TAINT_NOT; /* Each item is independent */
1843 PL_stack_sp = newsp;
1845 /* Stack values are safe: */
1847 POPSUB2(); /* release CV and @_ ... */
1849 PL_curpm = newpm; /* ... and pop $1 et al */
1852 return pop_return();
1859 register PERL_CONTEXT *cx;
1860 struct block_loop cxloop;
1861 struct block_sub cxsub;
1868 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1870 if (PL_op->op_flags & OPf_SPECIAL) {
1871 cxix = dopoptoloop(cxstack_ix);
1873 DIE("Can't \"last\" outside a block");
1876 cxix = dopoptolabel(cPVOP->op_pv);
1878 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1880 if (cxix < cxstack_ix)
1884 switch (CxTYPE(cx)) {
1886 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1888 nextop = cxloop.last_op->op_next;
1891 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1893 nextop = pop_return();
1897 nextop = pop_return();
1904 if (gimme == G_SCALAR) {
1906 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1907 ? *SP : sv_mortalcopy(*SP);
1909 *++newsp = &PL_sv_undef;
1911 else if (gimme == G_ARRAY) {
1912 while (++MARK <= SP) {
1913 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1914 ? *MARK : sv_mortalcopy(*MARK);
1915 TAINT_NOT; /* Each item is independent */
1921 /* Stack values are safe: */
1924 POPLOOP2(); /* release loop vars ... */
1928 POPSUB2(); /* release CV and @_ ... */
1931 PL_curpm = newpm; /* ... and pop $1 et al */
1940 register PERL_CONTEXT *cx;
1943 if (PL_op->op_flags & OPf_SPECIAL) {
1944 cxix = dopoptoloop(cxstack_ix);
1946 DIE("Can't \"next\" outside a block");
1949 cxix = dopoptolabel(cPVOP->op_pv);
1951 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1953 if (cxix < cxstack_ix)
1957 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1958 LEAVE_SCOPE(oldsave);
1959 return cx->blk_loop.next_op;
1965 register PERL_CONTEXT *cx;
1968 if (PL_op->op_flags & OPf_SPECIAL) {
1969 cxix = dopoptoloop(cxstack_ix);
1971 DIE("Can't \"redo\" outside a block");
1974 cxix = dopoptolabel(cPVOP->op_pv);
1976 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1978 if (cxix < cxstack_ix)
1982 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1983 LEAVE_SCOPE(oldsave);
1984 return cx->blk_loop.redo_op;
1988 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1992 static char too_deep[] = "Target of goto is too deeply nested";
1996 if (o->op_type == OP_LEAVE ||
1997 o->op_type == OP_SCOPE ||
1998 o->op_type == OP_LEAVELOOP ||
1999 o->op_type == OP_LEAVETRY)
2001 *ops++ = cUNOPo->op_first;
2006 if (o->op_flags & OPf_KIDS) {
2008 /* First try all the kids at this level, since that's likeliest. */
2009 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2010 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2011 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2014 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2015 if (kid == PL_lastgotoprobe)
2017 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2019 (ops[-1]->op_type != OP_NEXTSTATE &&
2020 ops[-1]->op_type != OP_DBSTATE)))
2022 if (o = dofindlabel(kid, label, ops, oplimit))
2032 return pp_goto(ARGS);
2041 register PERL_CONTEXT *cx;
2042 #define GOTO_DEPTH 64
2043 OP *enterops[GOTO_DEPTH];
2045 int do_dump = (PL_op->op_type == OP_DUMP);
2046 static char must_have_label[] = "goto must have label";
2049 if (PL_op->op_flags & OPf_STACKED) {
2053 /* This egregious kludge implements goto &subroutine */
2054 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2056 register PERL_CONTEXT *cx;
2057 CV* cv = (CV*)SvRV(sv);
2061 int arg_was_real = 0;
2064 if (!CvROOT(cv) && !CvXSUB(cv)) {
2069 /* autoloaded stub? */
2070 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2072 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2073 GvNAMELEN(gv), FALSE);
2074 if (autogv && (cv = GvCV(autogv)))
2076 tmpstr = sv_newmortal();
2077 gv_efullname3(tmpstr, gv, Nullch);
2078 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2080 DIE("Goto undefined subroutine");
2083 /* First do some returnish stuff. */
2084 cxix = dopoptosub(cxstack_ix);
2086 DIE("Can't goto subroutine outside a subroutine");
2087 if (cxix < cxstack_ix)
2090 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2091 DIE("Can't goto subroutine from an eval-string");
2093 if (CxTYPE(cx) == CXt_SUB &&
2094 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2095 AV* av = cx->blk_sub.argarray;
2097 items = AvFILLp(av) + 1;
2099 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2100 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2101 PL_stack_sp += items;
2103 SvREFCNT_dec(GvAV(PL_defgv));
2104 GvAV(PL_defgv) = cx->blk_sub.savearray;
2105 #endif /* USE_THREADS */
2108 AvREAL_off(av); /* so av_clear() won't clobber elts */
2112 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2116 av = (AV*)PL_curpad[0];
2118 av = GvAV(PL_defgv);
2120 items = AvFILLp(av) + 1;
2122 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2123 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2124 PL_stack_sp += items;
2126 if (CxTYPE(cx) == CXt_SUB &&
2127 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2128 SvREFCNT_dec(cx->blk_sub.cv);
2129 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2130 LEAVE_SCOPE(oldsave);
2132 /* Now do some callish stuff. */
2135 #ifdef PERL_XSUB_OLDSTYLE
2136 if (CvOLDSTYLE(cv)) {
2137 I32 (*fp3)_((int,int,int));
2142 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2143 items = (*fp3)(CvXSUBANY(cv).any_i32,
2144 mark - PL_stack_base + 1,
2146 SP = PL_stack_base + items;
2149 #endif /* PERL_XSUB_OLDSTYLE */
2154 PL_stack_sp--; /* There is no cv arg. */
2155 /* Push a mark for the start of arglist */
2157 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2158 /* Pop the current context like a decent sub should */
2159 POPBLOCK(cx, PL_curpm);
2160 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2163 return pop_return();
2166 AV* padlist = CvPADLIST(cv);
2167 SV** svp = AvARRAY(padlist);
2168 if (CxTYPE(cx) == CXt_EVAL) {
2169 PL_in_eval = cx->blk_eval.old_in_eval;
2170 PL_eval_root = cx->blk_eval.old_eval_root;
2171 cx->cx_type = CXt_SUB;
2172 cx->blk_sub.hasargs = 0;
2174 cx->blk_sub.cv = cv;
2175 cx->blk_sub.olddepth = CvDEPTH(cv);
2177 if (CvDEPTH(cv) < 2)
2178 (void)SvREFCNT_inc(cv);
2179 else { /* save temporaries on recursion? */
2180 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2181 sub_crush_depth(cv);
2182 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2183 AV *newpad = newAV();
2184 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2185 I32 ix = AvFILLp((AV*)svp[1]);
2186 svp = AvARRAY(svp[0]);
2187 for ( ;ix > 0; ix--) {
2188 if (svp[ix] != &PL_sv_undef) {
2189 char *name = SvPVX(svp[ix]);
2190 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2193 /* outer lexical or anon code */
2194 av_store(newpad, ix,
2195 SvREFCNT_inc(oldpad[ix]) );
2197 else { /* our own lexical */
2199 av_store(newpad, ix, sv = (SV*)newAV());
2200 else if (*name == '%')
2201 av_store(newpad, ix, sv = (SV*)newHV());
2203 av_store(newpad, ix, sv = NEWSV(0,0));
2208 av_store(newpad, ix, sv = NEWSV(0,0));
2212 if (cx->blk_sub.hasargs) {
2215 av_store(newpad, 0, (SV*)av);
2216 AvFLAGS(av) = AVf_REIFY;
2218 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2219 AvFILLp(padlist) = CvDEPTH(cv);
2220 svp = AvARRAY(padlist);
2224 if (!cx->blk_sub.hasargs) {
2225 AV* av = (AV*)PL_curpad[0];
2227 items = AvFILLp(av) + 1;
2229 /* Mark is at the end of the stack. */
2231 Copy(AvARRAY(av), SP + 1, items, SV*);
2236 #endif /* USE_THREADS */
2237 SAVESPTR(PL_curpad);
2238 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2240 if (cx->blk_sub.hasargs)
2241 #endif /* USE_THREADS */
2243 AV* av = (AV*)PL_curpad[0];
2247 cx->blk_sub.savearray = GvAV(PL_defgv);
2248 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2249 #endif /* USE_THREADS */
2250 cx->blk_sub.argarray = av;
2253 if (items >= AvMAX(av) + 1) {
2255 if (AvARRAY(av) != ary) {
2256 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2257 SvPVX(av) = (char*)ary;
2259 if (items >= AvMAX(av) + 1) {
2260 AvMAX(av) = items - 1;
2261 Renew(ary,items+1,SV*);
2263 SvPVX(av) = (char*)ary;
2266 Copy(mark,AvARRAY(av),items,SV*);
2267 AvFILLp(av) = items - 1;
2268 /* preserve @_ nature */
2279 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2281 * We do not care about using sv to call CV;
2282 * it's for informational purposes only.
2284 SV *sv = GvSV(PL_DBsub);
2287 if (PERLDB_SUB_NN) {
2288 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2291 gv_efullname3(sv, CvGV(cv), Nullch);
2294 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2295 PUSHMARK( PL_stack_sp );
2296 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2300 RETURNOP(CvSTART(cv));
2304 label = SvPV(sv,n_a);
2305 if (!(do_dump || *label))
2306 DIE(must_have_label);
2309 else if (PL_op->op_flags & OPf_SPECIAL) {
2311 DIE(must_have_label);
2314 label = cPVOP->op_pv;
2316 if (label && *label) {
2321 PL_lastgotoprobe = 0;
2323 for (ix = cxstack_ix; ix >= 0; ix--) {
2325 switch (CxTYPE(cx)) {
2327 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2330 gotoprobe = cx->blk_oldcop->op_sibling;
2336 gotoprobe = cx->blk_oldcop->op_sibling;
2338 gotoprobe = PL_main_root;
2341 if (CvDEPTH(cx->blk_sub.cv)) {
2342 gotoprobe = CvROOT(cx->blk_sub.cv);
2347 DIE("Can't \"goto\" outside a block");
2351 gotoprobe = PL_main_root;
2354 retop = dofindlabel(gotoprobe, label,
2355 enterops, enterops + GOTO_DEPTH);
2358 PL_lastgotoprobe = gotoprobe;
2361 DIE("Can't find label %s", label);
2363 /* pop unwanted frames */
2365 if (ix < cxstack_ix) {
2372 oldsave = PL_scopestack[PL_scopestack_ix];
2373 LEAVE_SCOPE(oldsave);
2376 /* push wanted frames */
2378 if (*enterops && enterops[1]) {
2380 for (ix = 1; enterops[ix]; ix++) {
2381 PL_op = enterops[ix];
2382 /* Eventually we may want to stack the needed arguments
2383 * for each op. For now, we punt on the hard ones. */
2384 if (PL_op->op_type == OP_ENTERITER)
2385 DIE("Can't \"goto\" into the middle of a foreach loop",
2387 (CALLOP->op_ppaddr)(ARGS);
2395 if (!retop) retop = PL_main_start;
2397 PL_restartop = retop;
2398 PL_do_undump = TRUE;
2402 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2403 PL_do_undump = FALSE;
2419 if (anum == 1 && VMSISH_EXIT)
2424 PUSHs(&PL_sv_undef);
2432 double value = SvNVx(GvSV(cCOP->cop_gv));
2433 register I32 match = I_32(value);
2436 if (((double)match) > value)
2437 --match; /* was fractional--truncate other way */
2439 match -= cCOP->uop.scop.scop_offset;
2442 else if (match > cCOP->uop.scop.scop_max)
2443 match = cCOP->uop.scop.scop_max;
2444 PL_op = cCOP->uop.scop.scop_next[match];
2454 PL_op = PL_op->op_next; /* can't assume anything */
2457 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2458 match -= cCOP->uop.scop.scop_offset;
2461 else if (match > cCOP->uop.scop.scop_max)
2462 match = cCOP->uop.scop.scop_max;
2463 PL_op = cCOP->uop.scop.scop_next[match];
2472 save_lines(AV *array, SV *sv)
2474 register char *s = SvPVX(sv);
2475 register char *send = SvPVX(sv) + SvCUR(sv);
2477 register I32 line = 1;
2479 while (s && s < send) {
2480 SV *tmpstr = NEWSV(85,0);
2482 sv_upgrade(tmpstr, SVt_PVMG);
2483 t = strchr(s, '\n');
2489 sv_setpvn(tmpstr, s, t - s);
2490 av_store(array, line++, tmpstr);
2496 docatch_body(va_list args)
2510 assert(CATCH_GET == TRUE);
2514 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body));
2520 PL_op = PL_restartop;
2535 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2536 /* sv Text to convert to OP tree. */
2537 /* startop op_free() this to undo. */
2538 /* code Short string id of the caller. */
2540 dSP; /* Make POPBLOCK work. */
2543 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2546 OP *oop = PL_op, *rop;
2547 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2553 /* switch to eval mode */
2555 if (PL_curcop == &PL_compiling) {
2556 SAVESPTR(PL_compiling.cop_stash);
2557 PL_compiling.cop_stash = PL_curstash;
2559 SAVESPTR(PL_compiling.cop_filegv);
2560 SAVEI16(PL_compiling.cop_line);
2561 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2562 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2563 PL_compiling.cop_line = 1;
2564 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2565 deleting the eval's FILEGV from the stash before gv_check() runs
2566 (i.e. before run-time proper). To work around the coredump that
2567 ensues, we always turn GvMULTI_on for any globals that were
2568 introduced within evals. See force_ident(). GSAR 96-10-12 */
2569 safestr = savepv(tmpbuf);
2570 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2572 #ifdef OP_IN_REGISTER
2580 PL_op->op_type = OP_ENTEREVAL;
2581 PL_op->op_flags = 0; /* Avoid uninit warning. */
2582 PUSHBLOCK(cx, CXt_EVAL, SP);
2583 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2584 rop = doeval(G_SCALAR, startop);
2585 POPBLOCK(cx,PL_curpm);
2588 (*startop)->op_type = OP_NULL;
2589 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2591 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2593 if (PL_curcop == &PL_compiling)
2594 PL_compiling.op_private = PL_hints;
2595 #ifdef OP_IN_REGISTER
2601 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2603 doeval(int gimme, OP** startop)
2616 /* set up a scratch pad */
2619 SAVESPTR(PL_curpad);
2620 SAVESPTR(PL_comppad);
2621 SAVESPTR(PL_comppad_name);
2622 SAVEI32(PL_comppad_name_fill);
2623 SAVEI32(PL_min_intro_pending);
2624 SAVEI32(PL_max_intro_pending);
2627 for (i = cxstack_ix - 1; i >= 0; i--) {
2628 PERL_CONTEXT *cx = &cxstack[i];
2629 if (CxTYPE(cx) == CXt_EVAL)
2631 else if (CxTYPE(cx) == CXt_SUB) {
2632 caller = cx->blk_sub.cv;
2637 SAVESPTR(PL_compcv);
2638 PL_compcv = (CV*)NEWSV(1104,0);
2639 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2640 CvEVAL_on(PL_compcv);
2642 CvOWNER(PL_compcv) = 0;
2643 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2644 MUTEX_INIT(CvMUTEXP(PL_compcv));
2645 #endif /* USE_THREADS */
2647 PL_comppad = newAV();
2648 av_push(PL_comppad, Nullsv);
2649 PL_curpad = AvARRAY(PL_comppad);
2650 PL_comppad_name = newAV();
2651 PL_comppad_name_fill = 0;
2652 PL_min_intro_pending = 0;
2655 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2656 PL_curpad[0] = (SV*)newAV();
2657 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2658 #endif /* USE_THREADS */
2660 comppadlist = newAV();
2661 AvREAL_off(comppadlist);
2662 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2663 av_store(comppadlist, 1, (SV*)PL_comppad);
2664 CvPADLIST(PL_compcv) = comppadlist;
2666 if (!saveop || saveop->op_type != OP_REQUIRE)
2667 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2669 SAVEFREESV(PL_compcv);
2671 /* make sure we compile in the right package */
2673 newstash = PL_curcop->cop_stash;
2674 if (PL_curstash != newstash) {
2675 SAVESPTR(PL_curstash);
2676 PL_curstash = newstash;
2678 SAVESPTR(PL_beginav);
2679 PL_beginav = newAV();
2680 SAVEFREESV(PL_beginav);
2682 /* try to compile it */
2684 PL_eval_root = Nullop;
2686 PL_curcop = &PL_compiling;
2687 PL_curcop->cop_arybase = 0;
2688 SvREFCNT_dec(PL_rs);
2689 PL_rs = newSVpvn("\n", 1);
2690 if (saveop && saveop->op_flags & OPf_SPECIAL)
2694 if (yyparse() || PL_error_count || !PL_eval_root) {
2698 I32 optype = 0; /* Might be reset by POPEVAL. */
2703 op_free(PL_eval_root);
2704 PL_eval_root = Nullop;
2706 SP = PL_stack_base + POPMARK; /* pop original mark */
2708 POPBLOCK(cx,PL_curpm);
2714 if (optype == OP_REQUIRE) {
2715 char* msg = SvPVx(ERRSV, n_a);
2716 DIE("%s", *msg ? msg : "Compilation failed in require");
2717 } else if (startop) {
2718 char* msg = SvPVx(ERRSV, n_a);
2720 POPBLOCK(cx,PL_curpm);
2722 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2724 SvREFCNT_dec(PL_rs);
2725 PL_rs = SvREFCNT_inc(PL_nrs);
2727 MUTEX_LOCK(&PL_eval_mutex);
2729 COND_SIGNAL(&PL_eval_cond);
2730 MUTEX_UNLOCK(&PL_eval_mutex);
2731 #endif /* USE_THREADS */
2734 SvREFCNT_dec(PL_rs);
2735 PL_rs = SvREFCNT_inc(PL_nrs);
2736 PL_compiling.cop_line = 0;
2738 *startop = PL_eval_root;
2739 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2740 CvOUTSIDE(PL_compcv) = Nullcv;
2742 SAVEFREEOP(PL_eval_root);
2744 scalarvoid(PL_eval_root);
2745 else if (gimme & G_ARRAY)
2748 scalar(PL_eval_root);
2750 DEBUG_x(dump_eval());
2752 /* Register with debugger: */
2753 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2754 CV *cv = perl_get_cv("DB::postponed", FALSE);
2758 XPUSHs((SV*)PL_compiling.cop_filegv);
2760 perl_call_sv((SV*)cv, G_DISCARD);
2764 /* compiled okay, so do it */
2766 CvDEPTH(PL_compcv) = 1;
2767 SP = PL_stack_base + POPMARK; /* pop original mark */
2768 PL_op = saveop; /* The caller may need it. */
2770 MUTEX_LOCK(&PL_eval_mutex);
2772 COND_SIGNAL(&PL_eval_cond);
2773 MUTEX_UNLOCK(&PL_eval_mutex);
2774 #endif /* USE_THREADS */
2776 RETURNOP(PL_eval_start);
2780 doopen_pmc(const char *name, const char *mode)
2782 STRLEN namelen = strlen(name);
2785 if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
2786 SV *pmcsv = newSVpvf("%s%c", name, 'c');
2787 char *pmc = SvPV_nolen(pmcsv);
2790 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2791 fp = PerlIO_open(name, mode);
2794 if (PerlLIO_stat(name, &pmstat) < 0 ||
2795 pmstat.st_mtime < pmcstat.st_mtime)
2797 fp = PerlIO_open(pmc, mode);
2800 fp = PerlIO_open(name, mode);
2803 SvREFCNT_dec(pmcsv);
2806 fp = PerlIO_open(name, mode);
2814 register PERL_CONTEXT *cx;
2819 SV *namesv = Nullsv;
2821 I32 gimme = G_SCALAR;
2822 PerlIO *tryrsfp = 0;
2826 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2827 SET_NUMERIC_STANDARD();
2828 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2829 DIE("Perl %s required--this is only version %s, stopped",
2830 SvPV(sv,n_a),PL_patchlevel);
2833 name = SvPV(sv, len);
2834 if (!(name && len > 0 && *name))
2835 DIE("Null filename used");
2836 TAINT_PROPER("require");
2837 if (PL_op->op_type == OP_REQUIRE &&
2838 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2839 *svp != &PL_sv_undef)
2842 /* prepare to compile file */
2847 (name[1] == '.' && name[2] == '/')))
2849 || (name[0] && name[1] == ':')
2852 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2855 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2856 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2861 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2864 AV *ar = GvAVn(PL_incgv);
2868 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2871 namesv = NEWSV(806, 0);
2872 for (i = 0; i <= AvFILL(ar); i++) {
2873 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2876 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2878 sv_setpv(namesv, unixdir);
2879 sv_catpv(namesv, unixname);
2881 sv_setpvf(namesv, "%s/%s", dir, name);
2883 TAINT_PROPER("require");
2884 tryname = SvPVX(namesv);
2885 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2887 if (tryname[0] == '.' && tryname[1] == '/')
2894 SAVESPTR(PL_compiling.cop_filegv);
2895 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2896 SvREFCNT_dec(namesv);
2898 if (PL_op->op_type == OP_REQUIRE) {
2899 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2900 SV *dirmsgsv = NEWSV(0, 0);
2901 AV *ar = GvAVn(PL_incgv);
2903 if (instr(SvPVX(msg), ".h "))
2904 sv_catpv(msg, " (change .h to .ph maybe?)");
2905 if (instr(SvPVX(msg), ".ph "))
2906 sv_catpv(msg, " (did you run h2ph?)");
2907 sv_catpv(msg, " (@INC contains:");
2908 for (i = 0; i <= AvFILL(ar); i++) {
2909 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2910 sv_setpvf(dirmsgsv, " %s", dir);
2911 sv_catsv(msg, dirmsgsv);
2913 sv_catpvn(msg, ")", 1);
2914 SvREFCNT_dec(dirmsgsv);
2921 SETERRNO(0, SS$_NORMAL);
2923 /* Assume success here to prevent recursive requirement. */
2924 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2925 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2929 lex_start(sv_2mortal(newSVpvn("",0)));
2930 SAVEGENERICSV(PL_rsfp_filters);
2931 PL_rsfp_filters = Nullav;
2934 name = savepv(name);
2938 SAVEPPTR(PL_compiling.cop_warnings);
2939 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2942 /* switch to eval mode */
2944 push_return(PL_op->op_next);
2945 PUSHBLOCK(cx, CXt_EVAL, SP);
2946 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2948 SAVEI16(PL_compiling.cop_line);
2949 PL_compiling.cop_line = 0;
2953 MUTEX_LOCK(&PL_eval_mutex);
2954 if (PL_eval_owner && PL_eval_owner != thr)
2955 while (PL_eval_owner)
2956 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2957 PL_eval_owner = thr;
2958 MUTEX_UNLOCK(&PL_eval_mutex);
2959 #endif /* USE_THREADS */
2960 return DOCATCH(doeval(G_SCALAR, NULL));
2965 return pp_require(ARGS);
2971 register PERL_CONTEXT *cx;
2973 I32 gimme = GIMME_V, was = PL_sub_generation;
2974 char tmpbuf[TYPE_DIGITS(long) + 12];
2979 if (!SvPV(sv,len) || !len)
2981 TAINT_PROPER("eval");
2987 /* switch to eval mode */
2989 SAVESPTR(PL_compiling.cop_filegv);
2990 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2991 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2992 PL_compiling.cop_line = 1;
2993 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2994 deleting the eval's FILEGV from the stash before gv_check() runs
2995 (i.e. before run-time proper). To work around the coredump that
2996 ensues, we always turn GvMULTI_on for any globals that were
2997 introduced within evals. See force_ident(). GSAR 96-10-12 */
2998 safestr = savepv(tmpbuf);
2999 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3001 PL_hints = PL_op->op_targ;
3002 SAVEPPTR(PL_compiling.cop_warnings);
3003 if (PL_compiling.cop_warnings != WARN_ALL
3004 && PL_compiling.cop_warnings != WARN_NONE){
3005 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3006 SAVEFREESV(PL_compiling.cop_warnings) ;
3009 push_return(PL_op->op_next);
3010 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3011 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3013 /* prepare to compile string */
3015 if (PERLDB_LINE && PL_curstash != PL_debstash)
3016 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3019 MUTEX_LOCK(&PL_eval_mutex);
3020 if (PL_eval_owner && PL_eval_owner != thr)
3021 while (PL_eval_owner)
3022 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3023 PL_eval_owner = thr;
3024 MUTEX_UNLOCK(&PL_eval_mutex);
3025 #endif /* USE_THREADS */
3026 ret = doeval(gimme, NULL);
3027 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3028 && ret != PL_op->op_next) { /* Successive compilation. */
3029 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3031 return DOCATCH(ret);
3041 register PERL_CONTEXT *cx;
3043 U8 save_flags = PL_op -> op_flags;
3048 retop = pop_return();
3051 if (gimme == G_VOID)
3053 else if (gimme == G_SCALAR) {
3056 if (SvFLAGS(TOPs) & SVs_TEMP)
3059 *MARK = sv_mortalcopy(TOPs);
3063 *MARK = &PL_sv_undef;
3067 /* in case LEAVE wipes old return values */
3068 for (mark = newsp + 1; mark <= SP; mark++) {
3069 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3070 *mark = sv_mortalcopy(*mark);
3071 TAINT_NOT; /* Each item is independent */
3075 PL_curpm = newpm; /* Don't pop $1 et al till now */
3078 * Closures mentioned at top level of eval cannot be referenced
3079 * again, and their presence indirectly causes a memory leak.
3080 * (Note that the fact that compcv and friends are still set here
3081 * is, AFAIK, an accident.) --Chip
3083 if (AvFILLp(PL_comppad_name) >= 0) {
3084 SV **svp = AvARRAY(PL_comppad_name);
3086 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3088 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3090 svp[ix] = &PL_sv_undef;
3094 SvREFCNT_dec(CvOUTSIDE(sv));
3095 CvOUTSIDE(sv) = Nullcv;
3108 assert(CvDEPTH(PL_compcv) == 1);
3110 CvDEPTH(PL_compcv) = 0;
3113 if (optype == OP_REQUIRE &&
3114 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3116 /* Unassume the success we assumed earlier. */
3117 char *name = cx->blk_eval.old_name;
3118 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3119 retop = die("%s did not return a true value", name);
3120 /* die_where() did LEAVE, or we won't be here */
3124 if (!(save_flags & OPf_SPECIAL))
3134 register PERL_CONTEXT *cx;
3135 I32 gimme = GIMME_V;
3140 push_return(cLOGOP->op_other->op_next);
3141 PUSHBLOCK(cx, CXt_EVAL, SP);
3143 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3148 return DOCATCH(PL_op->op_next);
3158 register PERL_CONTEXT *cx;
3166 if (gimme == G_VOID)
3168 else if (gimme == G_SCALAR) {
3171 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3174 *MARK = sv_mortalcopy(TOPs);
3178 *MARK = &PL_sv_undef;
3183 /* in case LEAVE wipes old return values */
3184 for (mark = newsp + 1; mark <= SP; mark++) {
3185 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3186 *mark = sv_mortalcopy(*mark);
3187 TAINT_NOT; /* Each item is independent */
3191 PL_curpm = newpm; /* Don't pop $1 et al till now */
3202 register char *s = SvPV_force(sv, len);
3203 register char *send = s + len;
3204 register char *base;
3205 register I32 skipspaces = 0;
3208 bool postspace = FALSE;
3216 croak("Null picture in formline");
3218 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3223 *fpc++ = FF_LINEMARK;
3224 noblank = repeat = FALSE;
3242 case ' ': case '\t':
3253 *fpc++ = FF_LITERAL;
3261 *fpc++ = skipspaces;
3265 *fpc++ = FF_NEWLINE;
3269 arg = fpc - linepc + 1;
3276 *fpc++ = FF_LINEMARK;
3277 noblank = repeat = FALSE;
3286 ischop = s[-1] == '^';
3292 arg = (s - base) - 1;
3294 *fpc++ = FF_LITERAL;
3303 *fpc++ = FF_LINEGLOB;
3305 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3306 arg = ischop ? 512 : 0;
3316 arg |= 256 + (s - f);
3318 *fpc++ = s - base; /* fieldsize for FETCH */
3319 *fpc++ = FF_DECIMAL;
3324 bool ismore = FALSE;
3327 while (*++s == '>') ;
3328 prespace = FF_SPACE;
3330 else if (*s == '|') {
3331 while (*++s == '|') ;
3332 prespace = FF_HALFSPACE;
3337 while (*++s == '<') ;
3340 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3344 *fpc++ = s - base; /* fieldsize for FETCH */
3346 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3364 { /* need to jump to the next word */
3366 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3367 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3368 s = SvPVX(sv) + SvCUR(sv) + z;
3370 Copy(fops, s, arg, U16);
3372 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3377 * The rest of this file was derived from source code contributed
3380 * NOTE: this code was derived from Tom Horsley's qsort replacement
3381 * and should not be confused with the original code.
3384 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3386 Permission granted to distribute under the same terms as perl which are
3389 This program is free software; you can redistribute it and/or modify
3390 it under the terms of either:
3392 a) the GNU General Public License as published by the Free
3393 Software Foundation; either version 1, or (at your option) any
3396 b) the "Artistic License" which comes with this Kit.
3398 Details on the perl license can be found in the perl source code which
3399 may be located via the www.perl.com web page.
3401 This is the most wonderfulest possible qsort I can come up with (and
3402 still be mostly portable) My (limited) tests indicate it consistently
3403 does about 20% fewer calls to compare than does the qsort in the Visual
3404 C++ library, other vendors may vary.
3406 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3407 others I invented myself (or more likely re-invented since they seemed
3408 pretty obvious once I watched the algorithm operate for a while).
3410 Most of this code was written while watching the Marlins sweep the Giants
3411 in the 1997 National League Playoffs - no Braves fans allowed to use this
3412 code (just kidding :-).
3414 I realize that if I wanted to be true to the perl tradition, the only
3415 comment in this file would be something like:
3417 ...they shuffled back towards the rear of the line. 'No, not at the
3418 rear!' the slave-driver shouted. 'Three files up. And stay there...
3420 However, I really needed to violate that tradition just so I could keep
3421 track of what happens myself, not to mention some poor fool trying to
3422 understand this years from now :-).
3425 /* ********************************************************** Configuration */
3427 #ifndef QSORT_ORDER_GUESS
3428 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3431 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3432 future processing - a good max upper bound is log base 2 of memory size
3433 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3434 safely be smaller than that since the program is taking up some space and
3435 most operating systems only let you grab some subset of contiguous
3436 memory (not to mention that you are normally sorting data larger than
3437 1 byte element size :-).
3439 #ifndef QSORT_MAX_STACK
3440 #define QSORT_MAX_STACK 32
3443 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3444 Anything bigger and we use qsort. If you make this too small, the qsort
3445 will probably break (or become less efficient), because it doesn't expect
3446 the middle element of a partition to be the same as the right or left -
3447 you have been warned).
3449 #ifndef QSORT_BREAK_EVEN
3450 #define QSORT_BREAK_EVEN 6
3453 /* ************************************************************* Data Types */
3455 /* hold left and right index values of a partition waiting to be sorted (the
3456 partition includes both left and right - right is NOT one past the end or
3457 anything like that).
3459 struct partition_stack_entry {
3462 #ifdef QSORT_ORDER_GUESS
3463 int qsort_break_even;
3467 /* ******************************************************* Shorthand Macros */
3469 /* Note that these macros will be used from inside the qsort function where
3470 we happen to know that the variable 'elt_size' contains the size of an
3471 array element and the variable 'temp' points to enough space to hold a
3472 temp element and the variable 'array' points to the array being sorted
3473 and 'compare' is the pointer to the compare routine.
3475 Also note that there are very many highly architecture specific ways
3476 these might be sped up, but this is simply the most generally portable
3477 code I could think of.
3480 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3483 #define qsort_cmp(elt1, elt2) \
3484 ((this->*compare)(array[elt1], array[elt2]))
3486 #define qsort_cmp(elt1, elt2) \
3487 ((*compare)(array[elt1], array[elt2]))
3490 #ifdef QSORT_ORDER_GUESS
3491 #define QSORT_NOTICE_SWAP swapped++;
3493 #define QSORT_NOTICE_SWAP
3496 /* swaps contents of array elements elt1, elt2.
3498 #define qsort_swap(elt1, elt2) \
3501 temp = array[elt1]; \
3502 array[elt1] = array[elt2]; \
3503 array[elt2] = temp; \
3506 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3507 elt3 and elt3 gets elt1.
3509 #define qsort_rotate(elt1, elt2, elt3) \
3512 temp = array[elt1]; \
3513 array[elt1] = array[elt2]; \
3514 array[elt2] = array[elt3]; \
3515 array[elt3] = temp; \
3518 /* ************************************************************ Debug stuff */
3525 return; /* good place to set a breakpoint */
3528 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3531 doqsort_all_asserts(
3535 int (*compare)(const void * elt1, const void * elt2),
3536 int pc_left, int pc_right, int u_left, int u_right)
3540 qsort_assert(pc_left <= pc_right);
3541 qsort_assert(u_right < pc_left);
3542 qsort_assert(pc_right < u_left);
3543 for (i = u_right + 1; i < pc_left; ++i) {
3544 qsort_assert(qsort_cmp(i, pc_left) < 0);
3546 for (i = pc_left; i < pc_right; ++i) {
3547 qsort_assert(qsort_cmp(i, pc_right) == 0);
3549 for (i = pc_right + 1; i < u_left; ++i) {
3550 qsort_assert(qsort_cmp(pc_right, i) < 0);
3554 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3555 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3556 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3560 #define qsort_assert(t) ((void)0)
3562 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3566 /* ****************************************************************** qsort */
3570 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3575 I32 (*compare)(SV *a, SV *b))
3580 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3581 int next_stack_entry = 0;
3585 #ifdef QSORT_ORDER_GUESS
3586 int qsort_break_even;
3590 /* Make sure we actually have work to do.
3592 if (num_elts <= 1) {
3596 /* Setup the initial partition definition and fall into the sorting loop
3599 part_right = (int)(num_elts - 1);
3600 #ifdef QSORT_ORDER_GUESS
3601 qsort_break_even = QSORT_BREAK_EVEN;
3603 #define qsort_break_even QSORT_BREAK_EVEN
3606 if ((part_right - part_left) >= qsort_break_even) {
3607 /* OK, this is gonna get hairy, so lets try to document all the
3608 concepts and abbreviations and variables and what they keep
3611 pc: pivot chunk - the set of array elements we accumulate in the
3612 middle of the partition, all equal in value to the original
3613 pivot element selected. The pc is defined by:
3615 pc_left - the leftmost array index of the pc
3616 pc_right - the rightmost array index of the pc
3618 we start with pc_left == pc_right and only one element
3619 in the pivot chunk (but it can grow during the scan).
3621 u: uncompared elements - the set of elements in the partition
3622 we have not yet compared to the pivot value. There are two
3623 uncompared sets during the scan - one to the left of the pc
3624 and one to the right.
3626 u_right - the rightmost index of the left side's uncompared set
3627 u_left - the leftmost index of the right side's uncompared set
3629 The leftmost index of the left sides's uncompared set
3630 doesn't need its own variable because it is always defined
3631 by the leftmost edge of the whole partition (part_left). The
3632 same goes for the rightmost edge of the right partition
3635 We know there are no uncompared elements on the left once we
3636 get u_right < part_left and no uncompared elements on the
3637 right once u_left > part_right. When both these conditions
3638 are met, we have completed the scan of the partition.
3640 Any elements which are between the pivot chunk and the
3641 uncompared elements should be less than the pivot value on
3642 the left side and greater than the pivot value on the right
3643 side (in fact, the goal of the whole algorithm is to arrange
3644 for that to be true and make the groups of less-than and
3645 greater-then elements into new partitions to sort again).
3647 As you marvel at the complexity of the code and wonder why it
3648 has to be so confusing. Consider some of the things this level
3649 of confusion brings:
3651 Once I do a compare, I squeeze every ounce of juice out of it. I
3652 never do compare calls I don't have to do, and I certainly never
3655 I also never swap any elements unless I can prove there is a
3656 good reason. Many sort algorithms will swap a known value with
3657 an uncompared value just to get things in the right place (or
3658 avoid complexity :-), but that uncompared value, once it gets
3659 compared, may then have to be swapped again. A lot of the
3660 complexity of this code is due to the fact that it never swaps
3661 anything except compared values, and it only swaps them when the
3662 compare shows they are out of position.
3664 int pc_left, pc_right;
3665 int u_right, u_left;
3669 pc_left = ((part_left + part_right) / 2);
3671 u_right = pc_left - 1;
3672 u_left = pc_right + 1;
3674 /* Qsort works best when the pivot value is also the median value
3675 in the partition (unfortunately you can't find the median value
3676 without first sorting :-), so to give the algorithm a helping
3677 hand, we pick 3 elements and sort them and use the median value
3678 of that tiny set as the pivot value.
3680 Some versions of qsort like to use the left middle and right as
3681 the 3 elements to sort so they can insure the ends of the
3682 partition will contain values which will stop the scan in the
3683 compare loop, but when you have to call an arbitrarily complex
3684 routine to do a compare, its really better to just keep track of
3685 array index values to know when you hit the edge of the
3686 partition and avoid the extra compare. An even better reason to
3687 avoid using a compare call is the fact that you can drop off the
3688 edge of the array if someone foolishly provides you with an
3689 unstable compare function that doesn't always provide consistent
3692 So, since it is simpler for us to compare the three adjacent
3693 elements in the middle of the partition, those are the ones we
3694 pick here (conveniently pointed at by u_right, pc_left, and
3695 u_left). The values of the left, center, and right elements
3696 are refered to as l c and r in the following comments.
3699 #ifdef QSORT_ORDER_GUESS
3702 s = qsort_cmp(u_right, pc_left);
3705 s = qsort_cmp(pc_left, u_left);
3706 /* if l < c, c < r - already in order - nothing to do */
3708 /* l < c, c == r - already in order, pc grows */
3710 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3712 /* l < c, c > r - need to know more */
3713 s = qsort_cmp(u_right, u_left);
3715 /* l < c, c > r, l < r - swap c & r to get ordered */
3716 qsort_swap(pc_left, u_left);
3717 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3718 } else if (s == 0) {
3719 /* l < c, c > r, l == r - swap c&r, grow pc */
3720 qsort_swap(pc_left, u_left);
3722 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3724 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3725 qsort_rotate(pc_left, u_right, u_left);
3726 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3729 } else if (s == 0) {
3731 s = qsort_cmp(pc_left, u_left);
3733 /* l == c, c < r - already in order, grow pc */
3735 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3736 } else if (s == 0) {
3737 /* l == c, c == r - already in order, grow pc both ways */
3740 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3742 /* l == c, c > r - swap l & r, grow pc */
3743 qsort_swap(u_right, u_left);
3745 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3749 s = qsort_cmp(pc_left, u_left);
3751 /* l > c, c < r - need to know more */
3752 s = qsort_cmp(u_right, u_left);
3754 /* l > c, c < r, l < r - swap l & c to get ordered */
3755 qsort_swap(u_right, pc_left);
3756 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3757 } else if (s == 0) {
3758 /* l > c, c < r, l == r - swap l & c, grow pc */
3759 qsort_swap(u_right, pc_left);
3761 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3763 /* l > c, c < r, l > r - rotate lcr into crl to order */
3764 qsort_rotate(u_right, pc_left, u_left);
3765 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3767 } else if (s == 0) {
3768 /* l > c, c == r - swap ends, grow pc */
3769 qsort_swap(u_right, u_left);
3771 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3773 /* l > c, c > r - swap ends to get in order */
3774 qsort_swap(u_right, u_left);
3775 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3778 /* We now know the 3 middle elements have been compared and
3779 arranged in the desired order, so we can shrink the uncompared
3784 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3786 /* The above massive nested if was the simple part :-). We now have
3787 the middle 3 elements ordered and we need to scan through the
3788 uncompared sets on either side, swapping elements that are on
3789 the wrong side or simply shuffling equal elements around to get
3790 all equal elements into the pivot chunk.
3794 int still_work_on_left;
3795 int still_work_on_right;
3797 /* Scan the uncompared values on the left. If I find a value
3798 equal to the pivot value, move it over so it is adjacent to
3799 the pivot chunk and expand the pivot chunk. If I find a value
3800 less than the pivot value, then just leave it - its already
3801 on the correct side of the partition. If I find a greater
3802 value, then stop the scan.
3804 while (still_work_on_left = (u_right >= part_left)) {
3805 s = qsort_cmp(u_right, pc_left);
3808 } else if (s == 0) {
3810 if (pc_left != u_right) {
3811 qsort_swap(u_right, pc_left);
3817 qsort_assert(u_right < pc_left);
3818 qsort_assert(pc_left <= pc_right);
3819 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3820 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3823 /* Do a mirror image scan of uncompared values on the right
3825 while (still_work_on_right = (u_left <= part_right)) {
3826 s = qsort_cmp(pc_right, u_left);
3829 } else if (s == 0) {
3831 if (pc_right != u_left) {
3832 qsort_swap(pc_right, u_left);
3838 qsort_assert(u_left > pc_right);
3839 qsort_assert(pc_left <= pc_right);
3840 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3841 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3844 if (still_work_on_left) {
3845 /* I know I have a value on the left side which needs to be
3846 on the right side, but I need to know more to decide
3847 exactly the best thing to do with it.
3849 if (still_work_on_right) {
3850 /* I know I have values on both side which are out of
3851 position. This is a big win because I kill two birds
3852 with one swap (so to speak). I can advance the
3853 uncompared pointers on both sides after swapping both
3854 of them into the right place.
3856 qsort_swap(u_right, u_left);
3859 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3861 /* I have an out of position value on the left, but the
3862 right is fully scanned, so I "slide" the pivot chunk
3863 and any less-than values left one to make room for the
3864 greater value over on the right. If the out of position
3865 value is immediately adjacent to the pivot chunk (there
3866 are no less-than values), I can do that with a swap,
3867 otherwise, I have to rotate one of the less than values
3868 into the former position of the out of position value
3869 and the right end of the pivot chunk into the left end
3873 if (pc_left == u_right) {
3874 qsort_swap(u_right, pc_right);
3875 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3877 qsort_rotate(u_right, pc_left, pc_right);
3878 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3883 } else if (still_work_on_right) {
3884 /* Mirror image of complex case above: I have an out of
3885 position value on the right, but the left is fully
3886 scanned, so I need to shuffle things around to make room
3887 for the right value on the left.
3890 if (pc_right == u_left) {
3891 qsort_swap(u_left, pc_left);
3892 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3894 qsort_rotate(pc_right, pc_left, u_left);
3895 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3900 /* No more scanning required on either side of partition,
3901 break out of loop and figure out next set of partitions
3907 /* The elements in the pivot chunk are now in the right place. They
3908 will never move or be compared again. All I have to do is decide
3909 what to do with the stuff to the left and right of the pivot
3912 Notes on the QSORT_ORDER_GUESS ifdef code:
3914 1. If I just built these partitions without swapping any (or
3915 very many) elements, there is a chance that the elements are
3916 already ordered properly (being properly ordered will
3917 certainly result in no swapping, but the converse can't be
3920 2. A (properly written) insertion sort will run faster on
3921 already ordered data than qsort will.
3923 3. Perhaps there is some way to make a good guess about
3924 switching to an insertion sort earlier than partition size 6
3925 (for instance - we could save the partition size on the stack
3926 and increase the size each time we find we didn't swap, thus
3927 switching to insertion sort earlier for partitions with a
3928 history of not swapping).
3930 4. Naturally, if I just switch right away, it will make
3931 artificial benchmarks with pure ascending (or descending)
3932 data look really good, but is that a good reason in general?
3936 #ifdef QSORT_ORDER_GUESS
3938 #if QSORT_ORDER_GUESS == 1
3939 qsort_break_even = (part_right - part_left) + 1;
3941 #if QSORT_ORDER_GUESS == 2
3942 qsort_break_even *= 2;
3944 #if QSORT_ORDER_GUESS == 3
3945 int prev_break = qsort_break_even;
3946 qsort_break_even *= qsort_break_even;
3947 if (qsort_break_even < prev_break) {
3948 qsort_break_even = (part_right - part_left) + 1;
3952 qsort_break_even = QSORT_BREAK_EVEN;
3956 if (part_left < pc_left) {
3957 /* There are elements on the left which need more processing.
3958 Check the right as well before deciding what to do.
3960 if (pc_right < part_right) {
3961 /* We have two partitions to be sorted. Stack the biggest one
3962 and process the smallest one on the next iteration. This
3963 minimizes the stack height by insuring that any additional
3964 stack entries must come from the smallest partition which
3965 (because it is smallest) will have the fewest
3966 opportunities to generate additional stack entries.
3968 if ((part_right - pc_right) > (pc_left - part_left)) {
3969 /* stack the right partition, process the left */
3970 partition_stack[next_stack_entry].left = pc_right + 1;
3971 partition_stack[next_stack_entry].right = part_right;
3972 #ifdef QSORT_ORDER_GUESS
3973 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3975 part_right = pc_left - 1;
3977 /* stack the left partition, process the right */
3978 partition_stack[next_stack_entry].left = part_left;
3979 partition_stack[next_stack_entry].right = pc_left - 1;
3980 #ifdef QSORT_ORDER_GUESS
3981 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3983 part_left = pc_right + 1;
3985 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3988 /* The elements on the left are the only remaining elements
3989 that need sorting, arrange for them to be processed as the
3992 part_right = pc_left - 1;
3994 } else if (pc_right < part_right) {
3995 /* There is only one chunk on the right to be sorted, make it
3996 the new partition and loop back around.
3998 part_left = pc_right + 1;
4000 /* This whole partition wound up in the pivot chunk, so
4001 we need to get a new partition off the stack.
4003 if (next_stack_entry == 0) {
4004 /* the stack is empty - we are done */
4008 part_left = partition_stack[next_stack_entry].left;
4009 part_right = partition_stack[next_stack_entry].right;
4010 #ifdef QSORT_ORDER_GUESS
4011 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4015 /* This partition is too small to fool with qsort complexity, just
4016 do an ordinary insertion sort to minimize overhead.
4019 /* Assume 1st element is in right place already, and start checking
4020 at 2nd element to see where it should be inserted.
4022 for (i = part_left + 1; i <= part_right; ++i) {
4024 /* Scan (backwards - just in case 'i' is already in right place)
4025 through the elements already sorted to see if the ith element
4026 belongs ahead of one of them.
4028 for (j = i - 1; j >= part_left; --j) {
4029 if (qsort_cmp(i, j) >= 0) {
4030 /* i belongs right after j
4037 /* Looks like we really need to move some things
4041 for (k = i - 1; k >= j; --k)
4042 array[k + 1] = array[k];
4047 /* That partition is now sorted, grab the next one, or get out
4048 of the loop if there aren't any more.
4051 if (next_stack_entry == 0) {
4052 /* the stack is empty - we are done */
4056 part_left = partition_stack[next_stack_entry].left;
4057 part_right = partition_stack[next_stack_entry].right;
4058 #ifdef QSORT_ORDER_GUESS
4059 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4064 /* Believe it or not, the array is sorted at this point! */