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)
670 XPUSHs(sv_2mortal(newSViv(0)));
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 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1030 return cCONDOP->op_false;
1032 return cCONDOP->op_true;
1039 if (GIMME == G_ARRAY) {
1040 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1044 SV *targ = PAD_SV(PL_op->op_targ);
1046 if ((PL_op->op_private & OPpFLIP_LINENUM)
1047 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1049 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1050 if (PL_op->op_flags & OPf_SPECIAL) {
1058 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1071 if (GIMME == G_ARRAY) {
1077 if (SvGMAGICAL(left))
1079 if (SvGMAGICAL(right))
1082 if (SvNIOKp(left) || !SvPOKp(left) ||
1083 (looks_like_number(left) && *SvPVX(left) != '0') )
1085 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1086 croak("Range iterator outside integer range");
1097 sv = sv_2mortal(newSViv(i++));
1102 SV *final = sv_mortalcopy(right);
1104 char *tmps = SvPV(final, len);
1106 sv = sv_mortalcopy(left);
1108 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1110 if (strEQ(SvPVX(sv),tmps))
1112 sv = sv_2mortal(newSVsv(sv));
1119 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1121 if ((PL_op->op_private & OPpFLIP_LINENUM)
1122 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1124 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1125 sv_catpv(targ, "E0");
1136 dopoptolabel(char *label)
1140 register PERL_CONTEXT *cx;
1142 for (i = cxstack_ix; i >= 0; i--) {
1144 switch (CxTYPE(cx)) {
1146 if (ckWARN(WARN_UNSAFE))
1147 warner(WARN_UNSAFE, "Exiting substitution via %s",
1148 PL_op_name[PL_op->op_type]);
1151 if (ckWARN(WARN_UNSAFE))
1152 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1153 PL_op_name[PL_op->op_type]);
1156 if (ckWARN(WARN_UNSAFE))
1157 warner(WARN_UNSAFE, "Exiting eval via %s",
1158 PL_op_name[PL_op->op_type]);
1161 if (ckWARN(WARN_UNSAFE))
1162 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1163 PL_op_name[PL_op->op_type]);
1166 if (!cx->blk_loop.label ||
1167 strNE(label, cx->blk_loop.label) ) {
1168 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1169 (long)i, cx->blk_loop.label));
1172 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1182 I32 gimme = block_gimme();
1183 return (gimme == G_VOID) ? G_SCALAR : gimme;
1192 cxix = dopoptosub(cxstack_ix);
1196 switch (cxstack[cxix].blk_gimme) {
1204 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1211 dopoptosub(I32 startingblock)
1214 return dopoptosub_at(cxstack, startingblock);
1218 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1222 register PERL_CONTEXT *cx;
1223 for (i = startingblock; i >= 0; i--) {
1225 switch (CxTYPE(cx)) {
1230 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1238 dopoptoeval(I32 startingblock)
1242 register PERL_CONTEXT *cx;
1243 for (i = startingblock; i >= 0; i--) {
1245 switch (CxTYPE(cx)) {
1249 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1257 dopoptoloop(I32 startingblock)
1261 register PERL_CONTEXT *cx;
1262 for (i = startingblock; i >= 0; i--) {
1264 switch (CxTYPE(cx)) {
1266 if (ckWARN(WARN_UNSAFE))
1267 warner(WARN_UNSAFE, "Exiting substitution via %s",
1268 PL_op_name[PL_op->op_type]);
1271 if (ckWARN(WARN_UNSAFE))
1272 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1273 PL_op_name[PL_op->op_type]);
1276 if (ckWARN(WARN_UNSAFE))
1277 warner(WARN_UNSAFE, "Exiting eval via %s",
1278 PL_op_name[PL_op->op_type]);
1281 if (ckWARN(WARN_UNSAFE))
1282 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1283 PL_op_name[PL_op->op_type]);
1286 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1297 register PERL_CONTEXT *cx;
1301 while (cxstack_ix > cxix) {
1302 cx = &cxstack[cxstack_ix];
1303 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1304 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1305 /* Note: we don't need to restore the base context info till the end. */
1306 switch (CxTYPE(cx)) {
1309 continue; /* not break */
1327 die_where(char *message, STRLEN msglen)
1333 register PERL_CONTEXT *cx;
1338 if (PL_in_eval & EVAL_KEEPERR) {
1341 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1344 static char prefix[] = "\t(in cleanup) ";
1346 sv_upgrade(*svp, SVt_IV);
1347 (void)SvIOK_only(*svp);
1350 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1351 sv_catpvn(err, prefix, sizeof(prefix)-1);
1352 sv_catpvn(err, message, msglen);
1353 if (ckWARN(WARN_UNSAFE)) {
1354 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1355 warner(WARN_UNSAFE, SvPVX(err)+start);
1362 sv_setpvn(ERRSV, message, msglen);
1365 message = SvPVx(ERRSV, msglen);
1367 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1375 if (cxix < cxstack_ix)
1378 POPBLOCK(cx,PL_curpm);
1379 if (CxTYPE(cx) != CXt_EVAL) {
1380 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1381 PerlIO_write(PerlIO_stderr(), message, msglen);
1386 if (gimme == G_SCALAR)
1387 *++newsp = &PL_sv_undef;
1388 PL_stack_sp = newsp;
1392 if (optype == OP_REQUIRE) {
1393 char* msg = SvPVx(ERRSV, n_a);
1394 DIE("%s", *msg ? msg : "Compilation failed in require");
1396 return pop_return();
1400 message = SvPVx(ERRSV, msglen);
1403 /* SFIO can really mess with your errno */
1406 PerlIO_write(PerlIO_stderr(), message, msglen);
1407 (void)PerlIO_flush(PerlIO_stderr());
1420 if (SvTRUE(left) != SvTRUE(right))
1432 RETURNOP(cLOGOP->op_other);
1441 RETURNOP(cLOGOP->op_other);
1447 register I32 cxix = dopoptosub(cxstack_ix);
1448 register PERL_CONTEXT *cx;
1449 register PERL_CONTEXT *ccstack = cxstack;
1450 PERL_SI *top_si = PL_curstackinfo;
1461 /* we may be in a higher stacklevel, so dig down deeper */
1462 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1463 top_si = top_si->si_prev;
1464 ccstack = top_si->si_cxstack;
1465 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1468 if (GIMME != G_ARRAY)
1472 if (PL_DBsub && cxix >= 0 &&
1473 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1477 cxix = dopoptosub_at(ccstack, cxix - 1);
1480 cx = &ccstack[cxix];
1481 if (CxTYPE(cx) == CXt_SUB) {
1482 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1483 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1484 field below is defined for any cx. */
1485 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1486 cx = &ccstack[dbcxix];
1489 if (GIMME != G_ARRAY) {
1490 hv = cx->blk_oldcop->cop_stash;
1492 PUSHs(&PL_sv_undef);
1495 sv_setpv(TARG, HvNAME(hv));
1501 hv = cx->blk_oldcop->cop_stash;
1503 PUSHs(&PL_sv_undef);
1505 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1506 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1507 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1508 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1511 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1513 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1514 PUSHs(sv_2mortal(sv));
1515 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1518 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1519 PUSHs(sv_2mortal(newSViv(0)));
1521 gimme = (I32)cx->blk_gimme;
1522 if (gimme == G_VOID)
1523 PUSHs(&PL_sv_undef);
1525 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1526 if (CxTYPE(cx) == CXt_EVAL) {
1527 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1528 PUSHs(cx->blk_eval.cur_text);
1531 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1532 /* Require, put the name. */
1533 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1537 else if (CxTYPE(cx) == CXt_SUB &&
1538 cx->blk_sub.hasargs &&
1539 PL_curcop->cop_stash == PL_debstash)
1541 AV *ary = cx->blk_sub.argarray;
1542 int off = AvARRAY(ary) - AvALLOC(ary);
1546 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1549 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1552 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1553 av_extend(PL_dbargs, AvFILLp(ary) + off);
1554 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1555 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1561 sortcv(SV *a, SV *b)
1564 I32 oldsaveix = PL_savestack_ix;
1565 I32 oldscopeix = PL_scopestack_ix;
1567 GvSV(PL_firstgv) = a;
1568 GvSV(PL_secondgv) = b;
1569 PL_stack_sp = PL_stack_base;
1572 if (PL_stack_sp != PL_stack_base + 1)
1573 croak("Sort subroutine didn't return single value");
1574 if (!SvNIOKp(*PL_stack_sp))
1575 croak("Sort subroutine didn't return a numeric value");
1576 result = SvIV(*PL_stack_sp);
1577 while (PL_scopestack_ix > oldscopeix) {
1580 leave_scope(oldsaveix);
1594 sv_reset(tmps, PL_curcop->cop_stash);
1606 PL_curcop = (COP*)PL_op;
1607 TAINT_NOT; /* Each statement is presumed innocent */
1608 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1611 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1615 register PERL_CONTEXT *cx;
1616 I32 gimme = G_ARRAY;
1623 DIE("No DB::DB routine defined");
1625 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1637 push_return(PL_op->op_next);
1638 PUSHBLOCK(cx, CXt_SUB, SP);
1641 (void)SvREFCNT_inc(cv);
1642 SAVESPTR(PL_curpad);
1643 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1644 RETURNOP(CvSTART(cv));
1658 register PERL_CONTEXT *cx;
1659 I32 gimme = GIMME_V;
1666 if (PL_op->op_flags & OPf_SPECIAL) {
1668 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1669 SAVEGENERICSV(*svp);
1673 #endif /* USE_THREADS */
1674 if (PL_op->op_targ) {
1675 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1679 svp = &GvSV((GV*)POPs); /* symbol table variable */
1680 SAVEGENERICSV(*svp);
1686 PUSHBLOCK(cx, CXt_LOOP, SP);
1687 PUSHLOOP(cx, svp, MARK);
1688 if (PL_op->op_flags & OPf_STACKED) {
1689 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1690 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1692 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1693 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1694 if (SvNV(sv) < IV_MIN ||
1695 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1696 croak("Range iterator outside integer range");
1697 cx->blk_loop.iterix = SvIV(sv);
1698 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1701 cx->blk_loop.iterlval = newSVsv(sv);
1705 cx->blk_loop.iterary = PL_curstack;
1706 AvFILLp(PL_curstack) = SP - PL_stack_base;
1707 cx->blk_loop.iterix = MARK - PL_stack_base;
1716 register PERL_CONTEXT *cx;
1717 I32 gimme = GIMME_V;
1723 PUSHBLOCK(cx, CXt_LOOP, SP);
1724 PUSHLOOP(cx, 0, SP);
1732 register PERL_CONTEXT *cx;
1733 struct block_loop cxloop;
1741 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1744 if (gimme == G_VOID)
1746 else if (gimme == G_SCALAR) {
1748 *++newsp = sv_mortalcopy(*SP);
1750 *++newsp = &PL_sv_undef;
1754 *++newsp = sv_mortalcopy(*++mark);
1755 TAINT_NOT; /* Each item is independent */
1761 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1762 PL_curpm = newpm; /* ... and pop $1 et al */
1774 register PERL_CONTEXT *cx;
1775 struct block_sub cxsub;
1776 bool popsub2 = FALSE;
1782 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1783 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1784 if (cxstack_ix > PL_sortcxix)
1785 dounwind(PL_sortcxix);
1786 AvARRAY(PL_curstack)[1] = *SP;
1787 PL_stack_sp = PL_stack_base + 1;
1792 cxix = dopoptosub(cxstack_ix);
1794 DIE("Can't return outside a subroutine");
1795 if (cxix < cxstack_ix)
1799 switch (CxTYPE(cx)) {
1801 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1806 if (optype == OP_REQUIRE &&
1807 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1809 /* Unassume the success we assumed earlier. */
1810 char *name = cx->blk_eval.old_name;
1811 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1812 DIE("%s did not return a true value", name);
1816 DIE("panic: return");
1820 if (gimme == G_SCALAR) {
1823 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1825 *++newsp = SvREFCNT_inc(*SP);
1830 *++newsp = sv_mortalcopy(*SP);
1833 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1835 *++newsp = sv_mortalcopy(*SP);
1837 *++newsp = &PL_sv_undef;
1839 else if (gimme == G_ARRAY) {
1840 while (++MARK <= SP) {
1841 *++newsp = (popsub2 && SvTEMP(*MARK))
1842 ? *MARK : sv_mortalcopy(*MARK);
1843 TAINT_NOT; /* Each item is independent */
1846 PL_stack_sp = newsp;
1848 /* Stack values are safe: */
1850 POPSUB2(); /* release CV and @_ ... */
1852 PL_curpm = newpm; /* ... and pop $1 et al */
1855 return pop_return();
1862 register PERL_CONTEXT *cx;
1863 struct block_loop cxloop;
1864 struct block_sub cxsub;
1871 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1873 if (PL_op->op_flags & OPf_SPECIAL) {
1874 cxix = dopoptoloop(cxstack_ix);
1876 DIE("Can't \"last\" outside a block");
1879 cxix = dopoptolabel(cPVOP->op_pv);
1881 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1883 if (cxix < cxstack_ix)
1887 switch (CxTYPE(cx)) {
1889 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1891 nextop = cxloop.last_op->op_next;
1894 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1896 nextop = pop_return();
1900 nextop = pop_return();
1907 if (gimme == G_SCALAR) {
1909 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1910 ? *SP : sv_mortalcopy(*SP);
1912 *++newsp = &PL_sv_undef;
1914 else if (gimme == G_ARRAY) {
1915 while (++MARK <= SP) {
1916 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1917 ? *MARK : sv_mortalcopy(*MARK);
1918 TAINT_NOT; /* Each item is independent */
1924 /* Stack values are safe: */
1927 POPLOOP2(); /* release loop vars ... */
1931 POPSUB2(); /* release CV and @_ ... */
1934 PL_curpm = newpm; /* ... and pop $1 et al */
1943 register PERL_CONTEXT *cx;
1946 if (PL_op->op_flags & OPf_SPECIAL) {
1947 cxix = dopoptoloop(cxstack_ix);
1949 DIE("Can't \"next\" outside a block");
1952 cxix = dopoptolabel(cPVOP->op_pv);
1954 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1956 if (cxix < cxstack_ix)
1960 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1961 LEAVE_SCOPE(oldsave);
1962 return cx->blk_loop.next_op;
1968 register PERL_CONTEXT *cx;
1971 if (PL_op->op_flags & OPf_SPECIAL) {
1972 cxix = dopoptoloop(cxstack_ix);
1974 DIE("Can't \"redo\" outside a block");
1977 cxix = dopoptolabel(cPVOP->op_pv);
1979 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1981 if (cxix < cxstack_ix)
1985 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1986 LEAVE_SCOPE(oldsave);
1987 return cx->blk_loop.redo_op;
1991 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1995 static char too_deep[] = "Target of goto is too deeply nested";
1999 if (o->op_type == OP_LEAVE ||
2000 o->op_type == OP_SCOPE ||
2001 o->op_type == OP_LEAVELOOP ||
2002 o->op_type == OP_LEAVETRY)
2004 *ops++ = cUNOPo->op_first;
2009 if (o->op_flags & OPf_KIDS) {
2011 /* First try all the kids at this level, since that's likeliest. */
2012 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2013 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2014 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2017 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2018 if (kid == PL_lastgotoprobe)
2020 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2022 (ops[-1]->op_type != OP_NEXTSTATE &&
2023 ops[-1]->op_type != OP_DBSTATE)))
2025 if (o = dofindlabel(kid, label, ops, oplimit))
2035 return pp_goto(ARGS);
2044 register PERL_CONTEXT *cx;
2045 #define GOTO_DEPTH 64
2046 OP *enterops[GOTO_DEPTH];
2048 int do_dump = (PL_op->op_type == OP_DUMP);
2049 static char must_have_label[] = "goto must have label";
2052 if (PL_op->op_flags & OPf_STACKED) {
2056 /* This egregious kludge implements goto &subroutine */
2057 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2059 register PERL_CONTEXT *cx;
2060 CV* cv = (CV*)SvRV(sv);
2064 int arg_was_real = 0;
2067 if (!CvROOT(cv) && !CvXSUB(cv)) {
2072 /* autoloaded stub? */
2073 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2075 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2076 GvNAMELEN(gv), FALSE);
2077 if (autogv && (cv = GvCV(autogv)))
2079 tmpstr = sv_newmortal();
2080 gv_efullname3(tmpstr, gv, Nullch);
2081 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2083 DIE("Goto undefined subroutine");
2086 /* First do some returnish stuff. */
2087 cxix = dopoptosub(cxstack_ix);
2089 DIE("Can't goto subroutine outside a subroutine");
2090 if (cxix < cxstack_ix)
2093 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2094 DIE("Can't goto subroutine from an eval-string");
2096 if (CxTYPE(cx) == CXt_SUB &&
2097 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2098 AV* av = cx->blk_sub.argarray;
2100 items = AvFILLp(av) + 1;
2102 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2103 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2104 PL_stack_sp += items;
2106 SvREFCNT_dec(GvAV(PL_defgv));
2107 GvAV(PL_defgv) = cx->blk_sub.savearray;
2108 #endif /* USE_THREADS */
2111 AvREAL_off(av); /* so av_clear() won't clobber elts */
2115 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2119 av = (AV*)PL_curpad[0];
2121 av = GvAV(PL_defgv);
2123 items = AvFILLp(av) + 1;
2125 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2126 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2127 PL_stack_sp += items;
2129 if (CxTYPE(cx) == CXt_SUB &&
2130 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2131 SvREFCNT_dec(cx->blk_sub.cv);
2132 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2133 LEAVE_SCOPE(oldsave);
2135 /* Now do some callish stuff. */
2138 #ifdef PERL_XSUB_OLDSTYLE
2139 if (CvOLDSTYLE(cv)) {
2140 I32 (*fp3)_((int,int,int));
2145 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2146 items = (*fp3)(CvXSUBANY(cv).any_i32,
2147 mark - PL_stack_base + 1,
2149 SP = PL_stack_base + items;
2152 #endif /* PERL_XSUB_OLDSTYLE */
2157 PL_stack_sp--; /* There is no cv arg. */
2158 /* Push a mark for the start of arglist */
2160 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2161 /* Pop the current context like a decent sub should */
2162 POPBLOCK(cx, PL_curpm);
2163 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2166 return pop_return();
2169 AV* padlist = CvPADLIST(cv);
2170 SV** svp = AvARRAY(padlist);
2171 if (CxTYPE(cx) == CXt_EVAL) {
2172 PL_in_eval = cx->blk_eval.old_in_eval;
2173 PL_eval_root = cx->blk_eval.old_eval_root;
2174 cx->cx_type = CXt_SUB;
2175 cx->blk_sub.hasargs = 0;
2177 cx->blk_sub.cv = cv;
2178 cx->blk_sub.olddepth = CvDEPTH(cv);
2180 if (CvDEPTH(cv) < 2)
2181 (void)SvREFCNT_inc(cv);
2182 else { /* save temporaries on recursion? */
2183 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2184 sub_crush_depth(cv);
2185 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2186 AV *newpad = newAV();
2187 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2188 I32 ix = AvFILLp((AV*)svp[1]);
2189 svp = AvARRAY(svp[0]);
2190 for ( ;ix > 0; ix--) {
2191 if (svp[ix] != &PL_sv_undef) {
2192 char *name = SvPVX(svp[ix]);
2193 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2196 /* outer lexical or anon code */
2197 av_store(newpad, ix,
2198 SvREFCNT_inc(oldpad[ix]) );
2200 else { /* our own lexical */
2202 av_store(newpad, ix, sv = (SV*)newAV());
2203 else if (*name == '%')
2204 av_store(newpad, ix, sv = (SV*)newHV());
2206 av_store(newpad, ix, sv = NEWSV(0,0));
2211 av_store(newpad, ix, sv = NEWSV(0,0));
2215 if (cx->blk_sub.hasargs) {
2218 av_store(newpad, 0, (SV*)av);
2219 AvFLAGS(av) = AVf_REIFY;
2221 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2222 AvFILLp(padlist) = CvDEPTH(cv);
2223 svp = AvARRAY(padlist);
2227 if (!cx->blk_sub.hasargs) {
2228 AV* av = (AV*)PL_curpad[0];
2230 items = AvFILLp(av) + 1;
2232 /* Mark is at the end of the stack. */
2234 Copy(AvARRAY(av), SP + 1, items, SV*);
2239 #endif /* USE_THREADS */
2240 SAVESPTR(PL_curpad);
2241 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2243 if (cx->blk_sub.hasargs)
2244 #endif /* USE_THREADS */
2246 AV* av = (AV*)PL_curpad[0];
2250 cx->blk_sub.savearray = GvAV(PL_defgv);
2251 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2252 #endif /* USE_THREADS */
2253 cx->blk_sub.argarray = av;
2256 if (items >= AvMAX(av) + 1) {
2258 if (AvARRAY(av) != ary) {
2259 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2260 SvPVX(av) = (char*)ary;
2262 if (items >= AvMAX(av) + 1) {
2263 AvMAX(av) = items - 1;
2264 Renew(ary,items+1,SV*);
2266 SvPVX(av) = (char*)ary;
2269 Copy(mark,AvARRAY(av),items,SV*);
2270 AvFILLp(av) = items - 1;
2271 /* preserve @_ nature */
2282 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2284 * We do not care about using sv to call CV;
2285 * it's for informational purposes only.
2287 SV *sv = GvSV(PL_DBsub);
2290 if (PERLDB_SUB_NN) {
2291 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2294 gv_efullname3(sv, CvGV(cv), Nullch);
2297 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2298 PUSHMARK( PL_stack_sp );
2299 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2303 RETURNOP(CvSTART(cv));
2307 label = SvPV(sv,n_a);
2308 if (!(do_dump || *label))
2309 DIE(must_have_label);
2312 else if (PL_op->op_flags & OPf_SPECIAL) {
2314 DIE(must_have_label);
2317 label = cPVOP->op_pv;
2319 if (label && *label) {
2324 PL_lastgotoprobe = 0;
2326 for (ix = cxstack_ix; ix >= 0; ix--) {
2328 switch (CxTYPE(cx)) {
2330 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2333 gotoprobe = cx->blk_oldcop->op_sibling;
2339 gotoprobe = cx->blk_oldcop->op_sibling;
2341 gotoprobe = PL_main_root;
2344 if (CvDEPTH(cx->blk_sub.cv)) {
2345 gotoprobe = CvROOT(cx->blk_sub.cv);
2350 DIE("Can't \"goto\" outside a block");
2354 gotoprobe = PL_main_root;
2357 retop = dofindlabel(gotoprobe, label,
2358 enterops, enterops + GOTO_DEPTH);
2361 PL_lastgotoprobe = gotoprobe;
2364 DIE("Can't find label %s", label);
2366 /* pop unwanted frames */
2368 if (ix < cxstack_ix) {
2375 oldsave = PL_scopestack[PL_scopestack_ix];
2376 LEAVE_SCOPE(oldsave);
2379 /* push wanted frames */
2381 if (*enterops && enterops[1]) {
2383 for (ix = 1; enterops[ix]; ix++) {
2384 PL_op = enterops[ix];
2385 /* Eventually we may want to stack the needed arguments
2386 * for each op. For now, we punt on the hard ones. */
2387 if (PL_op->op_type == OP_ENTERITER)
2388 DIE("Can't \"goto\" into the middle of a foreach loop",
2390 (CALLOP->op_ppaddr)(ARGS);
2398 if (!retop) retop = PL_main_start;
2400 PL_restartop = retop;
2401 PL_do_undump = TRUE;
2405 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2406 PL_do_undump = FALSE;
2422 if (anum == 1 && VMSISH_EXIT)
2427 PUSHs(&PL_sv_undef);
2435 double value = SvNVx(GvSV(cCOP->cop_gv));
2436 register I32 match = I_32(value);
2439 if (((double)match) > value)
2440 --match; /* was fractional--truncate other way */
2442 match -= cCOP->uop.scop.scop_offset;
2445 else if (match > cCOP->uop.scop.scop_max)
2446 match = cCOP->uop.scop.scop_max;
2447 PL_op = cCOP->uop.scop.scop_next[match];
2457 PL_op = PL_op->op_next; /* can't assume anything */
2460 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2461 match -= cCOP->uop.scop.scop_offset;
2464 else if (match > cCOP->uop.scop.scop_max)
2465 match = cCOP->uop.scop.scop_max;
2466 PL_op = cCOP->uop.scop.scop_next[match];
2475 save_lines(AV *array, SV *sv)
2477 register char *s = SvPVX(sv);
2478 register char *send = SvPVX(sv) + SvCUR(sv);
2480 register I32 line = 1;
2482 while (s && s < send) {
2483 SV *tmpstr = NEWSV(85,0);
2485 sv_upgrade(tmpstr, SVt_PVMG);
2486 t = strchr(s, '\n');
2492 sv_setpvn(tmpstr, s, t - s);
2493 av_store(array, line++, tmpstr);
2499 docatch_body(va_list args)
2513 assert(CATCH_GET == TRUE);
2517 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body));
2523 PL_op = PL_restartop;
2538 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2539 /* sv Text to convert to OP tree. */
2540 /* startop op_free() this to undo. */
2541 /* code Short string id of the caller. */
2543 dSP; /* Make POPBLOCK work. */
2546 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2549 OP *oop = PL_op, *rop;
2550 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2556 /* switch to eval mode */
2558 if (PL_curcop == &PL_compiling) {
2559 SAVESPTR(PL_compiling.cop_stash);
2560 PL_compiling.cop_stash = PL_curstash;
2562 SAVESPTR(PL_compiling.cop_filegv);
2563 SAVEI16(PL_compiling.cop_line);
2564 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2565 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2566 PL_compiling.cop_line = 1;
2567 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2568 deleting the eval's FILEGV from the stash before gv_check() runs
2569 (i.e. before run-time proper). To work around the coredump that
2570 ensues, we always turn GvMULTI_on for any globals that were
2571 introduced within evals. See force_ident(). GSAR 96-10-12 */
2572 safestr = savepv(tmpbuf);
2573 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2575 #ifdef OP_IN_REGISTER
2583 PL_op->op_type = OP_ENTEREVAL;
2584 PL_op->op_flags = 0; /* Avoid uninit warning. */
2585 PUSHBLOCK(cx, CXt_EVAL, SP);
2586 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2587 rop = doeval(G_SCALAR, startop);
2588 POPBLOCK(cx,PL_curpm);
2591 (*startop)->op_type = OP_NULL;
2592 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2594 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2596 if (PL_curcop == &PL_compiling)
2597 PL_compiling.op_private = PL_hints;
2598 #ifdef OP_IN_REGISTER
2604 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2606 doeval(int gimme, OP** startop)
2615 PL_in_eval = EVAL_INEVAL;
2619 /* set up a scratch pad */
2622 SAVESPTR(PL_curpad);
2623 SAVESPTR(PL_comppad);
2624 SAVESPTR(PL_comppad_name);
2625 SAVEI32(PL_comppad_name_fill);
2626 SAVEI32(PL_min_intro_pending);
2627 SAVEI32(PL_max_intro_pending);
2630 for (i = cxstack_ix - 1; i >= 0; i--) {
2631 PERL_CONTEXT *cx = &cxstack[i];
2632 if (CxTYPE(cx) == CXt_EVAL)
2634 else if (CxTYPE(cx) == CXt_SUB) {
2635 caller = cx->blk_sub.cv;
2640 SAVESPTR(PL_compcv);
2641 PL_compcv = (CV*)NEWSV(1104,0);
2642 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2643 CvEVAL_on(PL_compcv);
2645 CvOWNER(PL_compcv) = 0;
2646 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2647 MUTEX_INIT(CvMUTEXP(PL_compcv));
2648 #endif /* USE_THREADS */
2650 PL_comppad = newAV();
2651 av_push(PL_comppad, Nullsv);
2652 PL_curpad = AvARRAY(PL_comppad);
2653 PL_comppad_name = newAV();
2654 PL_comppad_name_fill = 0;
2655 PL_min_intro_pending = 0;
2658 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2659 PL_curpad[0] = (SV*)newAV();
2660 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2661 #endif /* USE_THREADS */
2663 comppadlist = newAV();
2664 AvREAL_off(comppadlist);
2665 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2666 av_store(comppadlist, 1, (SV*)PL_comppad);
2667 CvPADLIST(PL_compcv) = comppadlist;
2669 if (!saveop || saveop->op_type != OP_REQUIRE)
2670 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2672 SAVEFREESV(PL_compcv);
2674 /* make sure we compile in the right package */
2676 newstash = PL_curcop->cop_stash;
2677 if (PL_curstash != newstash) {
2678 SAVESPTR(PL_curstash);
2679 PL_curstash = newstash;
2681 SAVESPTR(PL_beginav);
2682 PL_beginav = newAV();
2683 SAVEFREESV(PL_beginav);
2685 /* try to compile it */
2687 PL_eval_root = Nullop;
2689 PL_curcop = &PL_compiling;
2690 PL_curcop->cop_arybase = 0;
2691 SvREFCNT_dec(PL_rs);
2692 PL_rs = newSVpvn("\n", 1);
2693 if (saveop && saveop->op_flags & OPf_SPECIAL)
2694 PL_in_eval |= EVAL_KEEPERR;
2697 if (yyparse() || PL_error_count || !PL_eval_root) {
2701 I32 optype = 0; /* Might be reset by POPEVAL. */
2706 op_free(PL_eval_root);
2707 PL_eval_root = Nullop;
2709 SP = PL_stack_base + POPMARK; /* pop original mark */
2711 POPBLOCK(cx,PL_curpm);
2717 if (optype == OP_REQUIRE) {
2718 char* msg = SvPVx(ERRSV, n_a);
2719 DIE("%s", *msg ? msg : "Compilation failed in require");
2720 } else if (startop) {
2721 char* msg = SvPVx(ERRSV, n_a);
2723 POPBLOCK(cx,PL_curpm);
2725 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2727 SvREFCNT_dec(PL_rs);
2728 PL_rs = SvREFCNT_inc(PL_nrs);
2730 MUTEX_LOCK(&PL_eval_mutex);
2732 COND_SIGNAL(&PL_eval_cond);
2733 MUTEX_UNLOCK(&PL_eval_mutex);
2734 #endif /* USE_THREADS */
2737 SvREFCNT_dec(PL_rs);
2738 PL_rs = SvREFCNT_inc(PL_nrs);
2739 PL_compiling.cop_line = 0;
2741 *startop = PL_eval_root;
2742 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2743 CvOUTSIDE(PL_compcv) = Nullcv;
2745 SAVEFREEOP(PL_eval_root);
2747 scalarvoid(PL_eval_root);
2748 else if (gimme & G_ARRAY)
2751 scalar(PL_eval_root);
2753 DEBUG_x(dump_eval());
2755 /* Register with debugger: */
2756 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2757 CV *cv = perl_get_cv("DB::postponed", FALSE);
2761 XPUSHs((SV*)PL_compiling.cop_filegv);
2763 perl_call_sv((SV*)cv, G_DISCARD);
2767 /* compiled okay, so do it */
2769 CvDEPTH(PL_compcv) = 1;
2770 SP = PL_stack_base + POPMARK; /* pop original mark */
2771 PL_op = saveop; /* The caller may need it. */
2773 MUTEX_LOCK(&PL_eval_mutex);
2775 COND_SIGNAL(&PL_eval_cond);
2776 MUTEX_UNLOCK(&PL_eval_mutex);
2777 #endif /* USE_THREADS */
2779 RETURNOP(PL_eval_start);
2783 doopen_pmc(const char *name, const char *mode)
2785 STRLEN namelen = strlen(name);
2788 if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
2789 SV *pmcsv = newSVpvf("%s%c", name, 'c');
2790 char *pmc = SvPV_nolen(pmcsv);
2793 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2794 fp = PerlIO_open(name, mode);
2797 if (PerlLIO_stat(name, &pmstat) < 0 ||
2798 pmstat.st_mtime < pmcstat.st_mtime)
2800 fp = PerlIO_open(pmc, mode);
2803 fp = PerlIO_open(name, mode);
2806 SvREFCNT_dec(pmcsv);
2809 fp = PerlIO_open(name, mode);
2817 register PERL_CONTEXT *cx;
2822 SV *namesv = Nullsv;
2824 I32 gimme = G_SCALAR;
2825 PerlIO *tryrsfp = 0;
2829 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2830 SET_NUMERIC_STANDARD();
2831 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2832 DIE("Perl %s required--this is only version %s, stopped",
2833 SvPV(sv,n_a),PL_patchlevel);
2836 name = SvPV(sv, len);
2837 if (!(name && len > 0 && *name))
2838 DIE("Null filename used");
2839 TAINT_PROPER("require");
2840 if (PL_op->op_type == OP_REQUIRE &&
2841 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2842 *svp != &PL_sv_undef)
2845 /* prepare to compile file */
2850 (name[1] == '.' && name[2] == '/')))
2852 || (name[0] && name[1] == ':')
2855 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2858 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2859 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2864 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2867 AV *ar = GvAVn(PL_incgv);
2871 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2874 namesv = NEWSV(806, 0);
2875 for (i = 0; i <= AvFILL(ar); i++) {
2876 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2879 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2881 sv_setpv(namesv, unixdir);
2882 sv_catpv(namesv, unixname);
2884 sv_setpvf(namesv, "%s/%s", dir, name);
2886 TAINT_PROPER("require");
2887 tryname = SvPVX(namesv);
2888 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2890 if (tryname[0] == '.' && tryname[1] == '/')
2897 SAVESPTR(PL_compiling.cop_filegv);
2898 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2899 SvREFCNT_dec(namesv);
2901 if (PL_op->op_type == OP_REQUIRE) {
2902 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2903 SV *dirmsgsv = NEWSV(0, 0);
2904 AV *ar = GvAVn(PL_incgv);
2906 if (instr(SvPVX(msg), ".h "))
2907 sv_catpv(msg, " (change .h to .ph maybe?)");
2908 if (instr(SvPVX(msg), ".ph "))
2909 sv_catpv(msg, " (did you run h2ph?)");
2910 sv_catpv(msg, " (@INC contains:");
2911 for (i = 0; i <= AvFILL(ar); i++) {
2912 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2913 sv_setpvf(dirmsgsv, " %s", dir);
2914 sv_catsv(msg, dirmsgsv);
2916 sv_catpvn(msg, ")", 1);
2917 SvREFCNT_dec(dirmsgsv);
2924 SETERRNO(0, SS$_NORMAL);
2926 /* Assume success here to prevent recursive requirement. */
2927 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2928 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2932 lex_start(sv_2mortal(newSVpvn("",0)));
2933 SAVEGENERICSV(PL_rsfp_filters);
2934 PL_rsfp_filters = Nullav;
2937 name = savepv(name);
2941 SAVEPPTR(PL_compiling.cop_warnings);
2942 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2945 /* switch to eval mode */
2947 push_return(PL_op->op_next);
2948 PUSHBLOCK(cx, CXt_EVAL, SP);
2949 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2951 SAVEI16(PL_compiling.cop_line);
2952 PL_compiling.cop_line = 0;
2956 MUTEX_LOCK(&PL_eval_mutex);
2957 if (PL_eval_owner && PL_eval_owner != thr)
2958 while (PL_eval_owner)
2959 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2960 PL_eval_owner = thr;
2961 MUTEX_UNLOCK(&PL_eval_mutex);
2962 #endif /* USE_THREADS */
2963 return DOCATCH(doeval(G_SCALAR, NULL));
2968 return pp_require(ARGS);
2974 register PERL_CONTEXT *cx;
2976 I32 gimme = GIMME_V, was = PL_sub_generation;
2977 char tmpbuf[TYPE_DIGITS(long) + 12];
2982 if (!SvPV(sv,len) || !len)
2984 TAINT_PROPER("eval");
2990 /* switch to eval mode */
2992 SAVESPTR(PL_compiling.cop_filegv);
2993 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2994 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2995 PL_compiling.cop_line = 1;
2996 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2997 deleting the eval's FILEGV from the stash before gv_check() runs
2998 (i.e. before run-time proper). To work around the coredump that
2999 ensues, we always turn GvMULTI_on for any globals that were
3000 introduced within evals. See force_ident(). GSAR 96-10-12 */
3001 safestr = savepv(tmpbuf);
3002 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3004 PL_hints = PL_op->op_targ;
3005 SAVEPPTR(PL_compiling.cop_warnings);
3006 if (PL_compiling.cop_warnings != WARN_ALL
3007 && PL_compiling.cop_warnings != WARN_NONE){
3008 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3009 SAVEFREESV(PL_compiling.cop_warnings) ;
3012 push_return(PL_op->op_next);
3013 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3014 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3016 /* prepare to compile string */
3018 if (PERLDB_LINE && PL_curstash != PL_debstash)
3019 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3022 MUTEX_LOCK(&PL_eval_mutex);
3023 if (PL_eval_owner && PL_eval_owner != thr)
3024 while (PL_eval_owner)
3025 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3026 PL_eval_owner = thr;
3027 MUTEX_UNLOCK(&PL_eval_mutex);
3028 #endif /* USE_THREADS */
3029 ret = doeval(gimme, NULL);
3030 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3031 && ret != PL_op->op_next) { /* Successive compilation. */
3032 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3034 return DOCATCH(ret);
3044 register PERL_CONTEXT *cx;
3046 U8 save_flags = PL_op -> op_flags;
3051 retop = pop_return();
3054 if (gimme == G_VOID)
3056 else if (gimme == G_SCALAR) {
3059 if (SvFLAGS(TOPs) & SVs_TEMP)
3062 *MARK = sv_mortalcopy(TOPs);
3066 *MARK = &PL_sv_undef;
3070 /* in case LEAVE wipes old return values */
3071 for (mark = newsp + 1; mark <= SP; mark++) {
3072 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3073 *mark = sv_mortalcopy(*mark);
3074 TAINT_NOT; /* Each item is independent */
3078 PL_curpm = newpm; /* Don't pop $1 et al till now */
3081 * Closures mentioned at top level of eval cannot be referenced
3082 * again, and their presence indirectly causes a memory leak.
3083 * (Note that the fact that compcv and friends are still set here
3084 * is, AFAIK, an accident.) --Chip
3086 if (AvFILLp(PL_comppad_name) >= 0) {
3087 SV **svp = AvARRAY(PL_comppad_name);
3089 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3091 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3093 svp[ix] = &PL_sv_undef;
3097 SvREFCNT_dec(CvOUTSIDE(sv));
3098 CvOUTSIDE(sv) = Nullcv;
3111 assert(CvDEPTH(PL_compcv) == 1);
3113 CvDEPTH(PL_compcv) = 0;
3116 if (optype == OP_REQUIRE &&
3117 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3119 /* Unassume the success we assumed earlier. */
3120 char *name = cx->blk_eval.old_name;
3121 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3122 retop = die("%s did not return a true value", name);
3123 /* die_where() did LEAVE, or we won't be here */
3127 if (!(save_flags & OPf_SPECIAL))
3137 register PERL_CONTEXT *cx;
3138 I32 gimme = GIMME_V;
3143 push_return(cLOGOP->op_other->op_next);
3144 PUSHBLOCK(cx, CXt_EVAL, SP);
3146 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3148 PL_in_eval = EVAL_INEVAL;
3151 return DOCATCH(PL_op->op_next);
3161 register PERL_CONTEXT *cx;
3169 if (gimme == G_VOID)
3171 else if (gimme == G_SCALAR) {
3174 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3177 *MARK = sv_mortalcopy(TOPs);
3181 *MARK = &PL_sv_undef;
3186 /* in case LEAVE wipes old return values */
3187 for (mark = newsp + 1; mark <= SP; mark++) {
3188 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3189 *mark = sv_mortalcopy(*mark);
3190 TAINT_NOT; /* Each item is independent */
3194 PL_curpm = newpm; /* Don't pop $1 et al till now */
3205 register char *s = SvPV_force(sv, len);
3206 register char *send = s + len;
3207 register char *base;
3208 register I32 skipspaces = 0;
3211 bool postspace = FALSE;
3219 croak("Null picture in formline");
3221 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3226 *fpc++ = FF_LINEMARK;
3227 noblank = repeat = FALSE;
3245 case ' ': case '\t':
3256 *fpc++ = FF_LITERAL;
3264 *fpc++ = skipspaces;
3268 *fpc++ = FF_NEWLINE;
3272 arg = fpc - linepc + 1;
3279 *fpc++ = FF_LINEMARK;
3280 noblank = repeat = FALSE;
3289 ischop = s[-1] == '^';
3295 arg = (s - base) - 1;
3297 *fpc++ = FF_LITERAL;
3306 *fpc++ = FF_LINEGLOB;
3308 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3309 arg = ischop ? 512 : 0;
3319 arg |= 256 + (s - f);
3321 *fpc++ = s - base; /* fieldsize for FETCH */
3322 *fpc++ = FF_DECIMAL;
3327 bool ismore = FALSE;
3330 while (*++s == '>') ;
3331 prespace = FF_SPACE;
3333 else if (*s == '|') {
3334 while (*++s == '|') ;
3335 prespace = FF_HALFSPACE;
3340 while (*++s == '<') ;
3343 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3347 *fpc++ = s - base; /* fieldsize for FETCH */
3349 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3367 { /* need to jump to the next word */
3369 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3370 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3371 s = SvPVX(sv) + SvCUR(sv) + z;
3373 Copy(fops, s, arg, U16);
3375 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3380 * The rest of this file was derived from source code contributed
3383 * NOTE: this code was derived from Tom Horsley's qsort replacement
3384 * and should not be confused with the original code.
3387 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3389 Permission granted to distribute under the same terms as perl which are
3392 This program is free software; you can redistribute it and/or modify
3393 it under the terms of either:
3395 a) the GNU General Public License as published by the Free
3396 Software Foundation; either version 1, or (at your option) any
3399 b) the "Artistic License" which comes with this Kit.
3401 Details on the perl license can be found in the perl source code which
3402 may be located via the www.perl.com web page.
3404 This is the most wonderfulest possible qsort I can come up with (and
3405 still be mostly portable) My (limited) tests indicate it consistently
3406 does about 20% fewer calls to compare than does the qsort in the Visual
3407 C++ library, other vendors may vary.
3409 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3410 others I invented myself (or more likely re-invented since they seemed
3411 pretty obvious once I watched the algorithm operate for a while).
3413 Most of this code was written while watching the Marlins sweep the Giants
3414 in the 1997 National League Playoffs - no Braves fans allowed to use this
3415 code (just kidding :-).
3417 I realize that if I wanted to be true to the perl tradition, the only
3418 comment in this file would be something like:
3420 ...they shuffled back towards the rear of the line. 'No, not at the
3421 rear!' the slave-driver shouted. 'Three files up. And stay there...
3423 However, I really needed to violate that tradition just so I could keep
3424 track of what happens myself, not to mention some poor fool trying to
3425 understand this years from now :-).
3428 /* ********************************************************** Configuration */
3430 #ifndef QSORT_ORDER_GUESS
3431 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3434 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3435 future processing - a good max upper bound is log base 2 of memory size
3436 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3437 safely be smaller than that since the program is taking up some space and
3438 most operating systems only let you grab some subset of contiguous
3439 memory (not to mention that you are normally sorting data larger than
3440 1 byte element size :-).
3442 #ifndef QSORT_MAX_STACK
3443 #define QSORT_MAX_STACK 32
3446 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3447 Anything bigger and we use qsort. If you make this too small, the qsort
3448 will probably break (or become less efficient), because it doesn't expect
3449 the middle element of a partition to be the same as the right or left -
3450 you have been warned).
3452 #ifndef QSORT_BREAK_EVEN
3453 #define QSORT_BREAK_EVEN 6
3456 /* ************************************************************* Data Types */
3458 /* hold left and right index values of a partition waiting to be sorted (the
3459 partition includes both left and right - right is NOT one past the end or
3460 anything like that).
3462 struct partition_stack_entry {
3465 #ifdef QSORT_ORDER_GUESS
3466 int qsort_break_even;
3470 /* ******************************************************* Shorthand Macros */
3472 /* Note that these macros will be used from inside the qsort function where
3473 we happen to know that the variable 'elt_size' contains the size of an
3474 array element and the variable 'temp' points to enough space to hold a
3475 temp element and the variable 'array' points to the array being sorted
3476 and 'compare' is the pointer to the compare routine.
3478 Also note that there are very many highly architecture specific ways
3479 these might be sped up, but this is simply the most generally portable
3480 code I could think of.
3483 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3486 #define qsort_cmp(elt1, elt2) \
3487 ((this->*compare)(array[elt1], array[elt2]))
3489 #define qsort_cmp(elt1, elt2) \
3490 ((*compare)(array[elt1], array[elt2]))
3493 #ifdef QSORT_ORDER_GUESS
3494 #define QSORT_NOTICE_SWAP swapped++;
3496 #define QSORT_NOTICE_SWAP
3499 /* swaps contents of array elements elt1, elt2.
3501 #define qsort_swap(elt1, elt2) \
3504 temp = array[elt1]; \
3505 array[elt1] = array[elt2]; \
3506 array[elt2] = temp; \
3509 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3510 elt3 and elt3 gets elt1.
3512 #define qsort_rotate(elt1, elt2, elt3) \
3515 temp = array[elt1]; \
3516 array[elt1] = array[elt2]; \
3517 array[elt2] = array[elt3]; \
3518 array[elt3] = temp; \
3521 /* ************************************************************ Debug stuff */
3528 return; /* good place to set a breakpoint */
3531 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3534 doqsort_all_asserts(
3538 int (*compare)(const void * elt1, const void * elt2),
3539 int pc_left, int pc_right, int u_left, int u_right)
3543 qsort_assert(pc_left <= pc_right);
3544 qsort_assert(u_right < pc_left);
3545 qsort_assert(pc_right < u_left);
3546 for (i = u_right + 1; i < pc_left; ++i) {
3547 qsort_assert(qsort_cmp(i, pc_left) < 0);
3549 for (i = pc_left; i < pc_right; ++i) {
3550 qsort_assert(qsort_cmp(i, pc_right) == 0);
3552 for (i = pc_right + 1; i < u_left; ++i) {
3553 qsort_assert(qsort_cmp(pc_right, i) < 0);
3557 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3558 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3559 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3563 #define qsort_assert(t) ((void)0)
3565 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3569 /* ****************************************************************** qsort */
3573 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3578 I32 (*compare)(SV *a, SV *b))
3583 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3584 int next_stack_entry = 0;
3588 #ifdef QSORT_ORDER_GUESS
3589 int qsort_break_even;
3593 /* Make sure we actually have work to do.
3595 if (num_elts <= 1) {
3599 /* Setup the initial partition definition and fall into the sorting loop
3602 part_right = (int)(num_elts - 1);
3603 #ifdef QSORT_ORDER_GUESS
3604 qsort_break_even = QSORT_BREAK_EVEN;
3606 #define qsort_break_even QSORT_BREAK_EVEN
3609 if ((part_right - part_left) >= qsort_break_even) {
3610 /* OK, this is gonna get hairy, so lets try to document all the
3611 concepts and abbreviations and variables and what they keep
3614 pc: pivot chunk - the set of array elements we accumulate in the
3615 middle of the partition, all equal in value to the original
3616 pivot element selected. The pc is defined by:
3618 pc_left - the leftmost array index of the pc
3619 pc_right - the rightmost array index of the pc
3621 we start with pc_left == pc_right and only one element
3622 in the pivot chunk (but it can grow during the scan).
3624 u: uncompared elements - the set of elements in the partition
3625 we have not yet compared to the pivot value. There are two
3626 uncompared sets during the scan - one to the left of the pc
3627 and one to the right.
3629 u_right - the rightmost index of the left side's uncompared set
3630 u_left - the leftmost index of the right side's uncompared set
3632 The leftmost index of the left sides's uncompared set
3633 doesn't need its own variable because it is always defined
3634 by the leftmost edge of the whole partition (part_left). The
3635 same goes for the rightmost edge of the right partition
3638 We know there are no uncompared elements on the left once we
3639 get u_right < part_left and no uncompared elements on the
3640 right once u_left > part_right. When both these conditions
3641 are met, we have completed the scan of the partition.
3643 Any elements which are between the pivot chunk and the
3644 uncompared elements should be less than the pivot value on
3645 the left side and greater than the pivot value on the right
3646 side (in fact, the goal of the whole algorithm is to arrange
3647 for that to be true and make the groups of less-than and
3648 greater-then elements into new partitions to sort again).
3650 As you marvel at the complexity of the code and wonder why it
3651 has to be so confusing. Consider some of the things this level
3652 of confusion brings:
3654 Once I do a compare, I squeeze every ounce of juice out of it. I
3655 never do compare calls I don't have to do, and I certainly never
3658 I also never swap any elements unless I can prove there is a
3659 good reason. Many sort algorithms will swap a known value with
3660 an uncompared value just to get things in the right place (or
3661 avoid complexity :-), but that uncompared value, once it gets
3662 compared, may then have to be swapped again. A lot of the
3663 complexity of this code is due to the fact that it never swaps
3664 anything except compared values, and it only swaps them when the
3665 compare shows they are out of position.
3667 int pc_left, pc_right;
3668 int u_right, u_left;
3672 pc_left = ((part_left + part_right) / 2);
3674 u_right = pc_left - 1;
3675 u_left = pc_right + 1;
3677 /* Qsort works best when the pivot value is also the median value
3678 in the partition (unfortunately you can't find the median value
3679 without first sorting :-), so to give the algorithm a helping
3680 hand, we pick 3 elements and sort them and use the median value
3681 of that tiny set as the pivot value.
3683 Some versions of qsort like to use the left middle and right as
3684 the 3 elements to sort so they can insure the ends of the
3685 partition will contain values which will stop the scan in the
3686 compare loop, but when you have to call an arbitrarily complex
3687 routine to do a compare, its really better to just keep track of
3688 array index values to know when you hit the edge of the
3689 partition and avoid the extra compare. An even better reason to
3690 avoid using a compare call is the fact that you can drop off the
3691 edge of the array if someone foolishly provides you with an
3692 unstable compare function that doesn't always provide consistent
3695 So, since it is simpler for us to compare the three adjacent
3696 elements in the middle of the partition, those are the ones we
3697 pick here (conveniently pointed at by u_right, pc_left, and
3698 u_left). The values of the left, center, and right elements
3699 are refered to as l c and r in the following comments.
3702 #ifdef QSORT_ORDER_GUESS
3705 s = qsort_cmp(u_right, pc_left);
3708 s = qsort_cmp(pc_left, u_left);
3709 /* if l < c, c < r - already in order - nothing to do */
3711 /* l < c, c == r - already in order, pc grows */
3713 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3715 /* l < c, c > r - need to know more */
3716 s = qsort_cmp(u_right, u_left);
3718 /* l < c, c > r, l < r - swap c & r to get ordered */
3719 qsort_swap(pc_left, u_left);
3720 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3721 } else if (s == 0) {
3722 /* l < c, c > r, l == r - swap c&r, grow pc */
3723 qsort_swap(pc_left, u_left);
3725 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3727 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3728 qsort_rotate(pc_left, u_right, u_left);
3729 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3732 } else if (s == 0) {
3734 s = qsort_cmp(pc_left, u_left);
3736 /* l == c, c < r - already in order, grow pc */
3738 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3739 } else if (s == 0) {
3740 /* l == c, c == r - already in order, grow pc both ways */
3743 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3745 /* l == c, c > r - swap l & r, grow pc */
3746 qsort_swap(u_right, u_left);
3748 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3752 s = qsort_cmp(pc_left, u_left);
3754 /* l > c, c < r - need to know more */
3755 s = qsort_cmp(u_right, u_left);
3757 /* l > c, c < r, l < r - swap l & c to get ordered */
3758 qsort_swap(u_right, pc_left);
3759 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3760 } else if (s == 0) {
3761 /* l > c, c < r, l == r - swap l & c, grow pc */
3762 qsort_swap(u_right, pc_left);
3764 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3766 /* l > c, c < r, l > r - rotate lcr into crl to order */
3767 qsort_rotate(u_right, pc_left, u_left);
3768 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3770 } else if (s == 0) {
3771 /* l > c, c == r - swap ends, grow pc */
3772 qsort_swap(u_right, u_left);
3774 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3776 /* l > c, c > r - swap ends to get in order */
3777 qsort_swap(u_right, u_left);
3778 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3781 /* We now know the 3 middle elements have been compared and
3782 arranged in the desired order, so we can shrink the uncompared
3787 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3789 /* The above massive nested if was the simple part :-). We now have
3790 the middle 3 elements ordered and we need to scan through the
3791 uncompared sets on either side, swapping elements that are on
3792 the wrong side or simply shuffling equal elements around to get
3793 all equal elements into the pivot chunk.
3797 int still_work_on_left;
3798 int still_work_on_right;
3800 /* Scan the uncompared values on the left. If I find a value
3801 equal to the pivot value, move it over so it is adjacent to
3802 the pivot chunk and expand the pivot chunk. If I find a value
3803 less than the pivot value, then just leave it - its already
3804 on the correct side of the partition. If I find a greater
3805 value, then stop the scan.
3807 while (still_work_on_left = (u_right >= part_left)) {
3808 s = qsort_cmp(u_right, pc_left);
3811 } else if (s == 0) {
3813 if (pc_left != u_right) {
3814 qsort_swap(u_right, pc_left);
3820 qsort_assert(u_right < pc_left);
3821 qsort_assert(pc_left <= pc_right);
3822 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3823 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3826 /* Do a mirror image scan of uncompared values on the right
3828 while (still_work_on_right = (u_left <= part_right)) {
3829 s = qsort_cmp(pc_right, u_left);
3832 } else if (s == 0) {
3834 if (pc_right != u_left) {
3835 qsort_swap(pc_right, u_left);
3841 qsort_assert(u_left > pc_right);
3842 qsort_assert(pc_left <= pc_right);
3843 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3844 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3847 if (still_work_on_left) {
3848 /* I know I have a value on the left side which needs to be
3849 on the right side, but I need to know more to decide
3850 exactly the best thing to do with it.
3852 if (still_work_on_right) {
3853 /* I know I have values on both side which are out of
3854 position. This is a big win because I kill two birds
3855 with one swap (so to speak). I can advance the
3856 uncompared pointers on both sides after swapping both
3857 of them into the right place.
3859 qsort_swap(u_right, u_left);
3862 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3864 /* I have an out of position value on the left, but the
3865 right is fully scanned, so I "slide" the pivot chunk
3866 and any less-than values left one to make room for the
3867 greater value over on the right. If the out of position
3868 value is immediately adjacent to the pivot chunk (there
3869 are no less-than values), I can do that with a swap,
3870 otherwise, I have to rotate one of the less than values
3871 into the former position of the out of position value
3872 and the right end of the pivot chunk into the left end
3876 if (pc_left == u_right) {
3877 qsort_swap(u_right, pc_right);
3878 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3880 qsort_rotate(u_right, pc_left, pc_right);
3881 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3886 } else if (still_work_on_right) {
3887 /* Mirror image of complex case above: I have an out of
3888 position value on the right, but the left is fully
3889 scanned, so I need to shuffle things around to make room
3890 for the right value on the left.
3893 if (pc_right == u_left) {
3894 qsort_swap(u_left, pc_left);
3895 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3897 qsort_rotate(pc_right, pc_left, u_left);
3898 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3903 /* No more scanning required on either side of partition,
3904 break out of loop and figure out next set of partitions
3910 /* The elements in the pivot chunk are now in the right place. They
3911 will never move or be compared again. All I have to do is decide
3912 what to do with the stuff to the left and right of the pivot
3915 Notes on the QSORT_ORDER_GUESS ifdef code:
3917 1. If I just built these partitions without swapping any (or
3918 very many) elements, there is a chance that the elements are
3919 already ordered properly (being properly ordered will
3920 certainly result in no swapping, but the converse can't be
3923 2. A (properly written) insertion sort will run faster on
3924 already ordered data than qsort will.
3926 3. Perhaps there is some way to make a good guess about
3927 switching to an insertion sort earlier than partition size 6
3928 (for instance - we could save the partition size on the stack
3929 and increase the size each time we find we didn't swap, thus
3930 switching to insertion sort earlier for partitions with a
3931 history of not swapping).
3933 4. Naturally, if I just switch right away, it will make
3934 artificial benchmarks with pure ascending (or descending)
3935 data look really good, but is that a good reason in general?
3939 #ifdef QSORT_ORDER_GUESS
3941 #if QSORT_ORDER_GUESS == 1
3942 qsort_break_even = (part_right - part_left) + 1;
3944 #if QSORT_ORDER_GUESS == 2
3945 qsort_break_even *= 2;
3947 #if QSORT_ORDER_GUESS == 3
3948 int prev_break = qsort_break_even;
3949 qsort_break_even *= qsort_break_even;
3950 if (qsort_break_even < prev_break) {
3951 qsort_break_even = (part_right - part_left) + 1;
3955 qsort_break_even = QSORT_BREAK_EVEN;
3959 if (part_left < pc_left) {
3960 /* There are elements on the left which need more processing.
3961 Check the right as well before deciding what to do.
3963 if (pc_right < part_right) {
3964 /* We have two partitions to be sorted. Stack the biggest one
3965 and process the smallest one on the next iteration. This
3966 minimizes the stack height by insuring that any additional
3967 stack entries must come from the smallest partition which
3968 (because it is smallest) will have the fewest
3969 opportunities to generate additional stack entries.
3971 if ((part_right - pc_right) > (pc_left - part_left)) {
3972 /* stack the right partition, process the left */
3973 partition_stack[next_stack_entry].left = pc_right + 1;
3974 partition_stack[next_stack_entry].right = part_right;
3975 #ifdef QSORT_ORDER_GUESS
3976 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3978 part_right = pc_left - 1;
3980 /* stack the left partition, process the right */
3981 partition_stack[next_stack_entry].left = part_left;
3982 partition_stack[next_stack_entry].right = pc_left - 1;
3983 #ifdef QSORT_ORDER_GUESS
3984 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3986 part_left = pc_right + 1;
3988 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3991 /* The elements on the left are the only remaining elements
3992 that need sorting, arrange for them to be processed as the
3995 part_right = pc_left - 1;
3997 } else if (pc_right < part_right) {
3998 /* There is only one chunk on the right to be sorted, make it
3999 the new partition and loop back around.
4001 part_left = pc_right + 1;
4003 /* This whole partition wound up in the pivot chunk, so
4004 we need to get a new partition off the stack.
4006 if (next_stack_entry == 0) {
4007 /* the stack is empty - we are done */
4011 part_left = partition_stack[next_stack_entry].left;
4012 part_right = partition_stack[next_stack_entry].right;
4013 #ifdef QSORT_ORDER_GUESS
4014 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4018 /* This partition is too small to fool with qsort complexity, just
4019 do an ordinary insertion sort to minimize overhead.
4022 /* Assume 1st element is in right place already, and start checking
4023 at 2nd element to see where it should be inserted.
4025 for (i = part_left + 1; i <= part_right; ++i) {
4027 /* Scan (backwards - just in case 'i' is already in right place)
4028 through the elements already sorted to see if the ith element
4029 belongs ahead of one of them.
4031 for (j = i - 1; j >= part_left; --j) {
4032 if (qsort_cmp(i, j) >= 0) {
4033 /* i belongs right after j
4040 /* Looks like we really need to move some things
4044 for (k = i - 1; k >= j; --k)
4045 array[k + 1] = array[k];
4050 /* That partition is now sorted, grab the next one, or get out
4051 of the loop if there aren't any more.
4054 if (next_stack_entry == 0) {
4055 /* the stack is empty - we are done */
4059 part_left = partition_stack[next_stack_entry].left;
4060 part_right = partition_stack[next_stack_entry].right;
4061 #ifdef QSORT_ORDER_GUESS
4062 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4067 /* Believe it or not, the array is sorted at this point! */