3 * Copyright (c) 1991-2000, 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.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 sortcv(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, 'r');
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
118 pm->op_pmdynflags |= PMdf_UTF8;
119 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
120 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
121 inside tie/overload accessors. */
125 #ifndef INCOMPLETE_TAINTS
128 pm->op_pmdynflags |= PMdf_TAINTED;
130 pm->op_pmdynflags &= ~PMdf_TAINTED;
134 if (!pm->op_pmregexp->prelen && PL_curpm)
136 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
137 pm->op_pmflags |= PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
143 /* XXX can't change the optree at runtime either */
144 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(aTHX_ "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(aTHX_ rx, s, cx->sb_strend, orig,
173 s == m, cx->sb_targ, NULL,
174 ((cx->sb_rflags & REXEC_COPY_STR)
175 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
176 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
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_MATCH_COPIED(rx) && rx->subbeg != orig) {
207 cx->sb_orig = orig = rx->subbeg;
209 cx->sb_strend = s + (cx->sb_strend - m);
211 cx->sb_m = m = rx->startp[0] + orig;
212 sv_catpvn(dstr, s, m-s);
213 cx->sb_s = rx->endp[0] + orig;
214 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
215 rxres_save(&cx->sb_rxres, rx);
216 RETURNOP(pm->op_pmreplstart);
220 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
225 if (!p || p[1] < rx->nparens) {
226 i = 6 + rx->nparens * 2;
234 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
235 RX_MATCH_COPIED_off(rx);
239 *p++ = PTR2UV(rx->subbeg);
240 *p++ = (UV)rx->sublen;
241 for (i = 0; i <= rx->nparens; ++i) {
242 *p++ = (UV)rx->startp[i];
243 *p++ = (UV)rx->endp[i];
248 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
253 if (RX_MATCH_COPIED(rx))
254 Safefree(rx->subbeg);
255 RX_MATCH_COPIED_set(rx, *p);
260 rx->subbeg = INT2PTR(char*,*p++);
261 rx->sublen = (I32)(*p++);
262 for (i = 0; i <= rx->nparens; ++i) {
263 rx->startp[i] = (I32)(*p++);
264 rx->endp[i] = (I32)(*p++);
269 Perl_rxres_free(pTHX_ void **rsp)
274 Safefree(INT2PTR(char*,*p));
282 djSP; dMARK; dORIGMARK;
283 register SV *tmpForm = *++MARK;
295 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
301 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
302 bool item_is_utf = FALSE;
304 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
305 if (SvREADONLY(tmpForm)) {
306 SvREADONLY_off(tmpForm);
307 doparseform(tmpForm);
308 SvREADONLY_on(tmpForm);
311 doparseform(tmpForm);
314 SvPV_force(PL_formtarget, len);
315 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
317 f = SvPV(tmpForm, len);
318 /* need to jump to the next word */
319 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
328 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
329 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
330 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
331 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
332 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
334 case FF_CHECKNL: name = "CHECKNL"; break;
335 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
336 case FF_SPACE: name = "SPACE"; break;
337 case FF_HALFSPACE: name = "HALFSPACE"; break;
338 case FF_ITEM: name = "ITEM"; break;
339 case FF_CHOP: name = "CHOP"; break;
340 case FF_LINEGLOB: name = "LINEGLOB"; break;
341 case FF_NEWLINE: name = "NEWLINE"; break;
342 case FF_MORE: name = "MORE"; break;
343 case FF_LINEMARK: name = "LINEMARK"; break;
344 case FF_END: name = "END"; break;
347 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
349 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
377 if (ckWARN(WARN_SYNTAX))
378 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
383 item = s = SvPV(sv, len);
386 itemsize = sv_len_utf8(sv);
387 if (itemsize != len) {
389 if (itemsize > fieldsize) {
390 itemsize = fieldsize;
391 itembytes = itemsize;
392 sv_pos_u2b(sv, &itembytes, 0);
396 send = chophere = s + itembytes;
406 sv_pos_b2u(sv, &itemsize);
411 if (itemsize > fieldsize)
412 itemsize = fieldsize;
413 send = chophere = s + itemsize;
425 item = s = SvPV(sv, len);
428 itemsize = sv_len_utf8(sv);
429 if (itemsize != len) {
431 if (itemsize <= fieldsize) {
432 send = chophere = s + itemsize;
443 itemsize = fieldsize;
444 itembytes = itemsize;
445 sv_pos_u2b(sv, &itembytes, 0);
446 send = chophere = s + itembytes;
447 while (s < send || (s == send && isSPACE(*s))) {
457 if (strchr(PL_chopset, *s))
462 itemsize = chophere - item;
463 sv_pos_b2u(sv, &itemsize);
470 if (itemsize <= fieldsize) {
471 send = chophere = s + itemsize;
482 itemsize = fieldsize;
483 send = chophere = s + itemsize;
484 while (s < send || (s == send && isSPACE(*s))) {
494 if (strchr(PL_chopset, *s))
499 itemsize = chophere - item;
504 arg = fieldsize - itemsize;
513 arg = fieldsize - itemsize;
528 switch (UTF8SKIP(s)) {
539 if ( !((*t++ = *s++) & ~31) )
547 int ch = *t++ = *s++;
550 if ( !((*t++ = *s++) & ~31) )
559 while (*s && isSPACE(*s))
566 item = s = SvPV(sv, len);
568 item_is_utf = FALSE; /* XXX is this correct? */
580 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
581 sv_catpvn(PL_formtarget, item, itemsize);
582 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
583 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
588 /* If the field is marked with ^ and the value is undefined,
591 if ((arg & 512) && !SvOK(sv)) {
599 /* Formats aren't yet marked for locales, so assume "yes". */
601 RESTORE_NUMERIC_LOCAL();
602 #if defined(USE_LONG_DOUBLE)
604 sprintf(t, "%#*.*" PERL_PRIfldbl,
605 (int) fieldsize, (int) arg & 255, value);
607 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
612 (int) fieldsize, (int) arg & 255, value);
615 (int) fieldsize, value);
618 RESTORE_NUMERIC_STANDARD();
625 while (t-- > linemark && *t == ' ') ;
633 if (arg) { /* repeat until fields exhausted? */
635 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
636 lines += FmLINES(PL_formtarget);
639 if (strnEQ(linemark, linemark - arg, arg))
640 DIE(aTHX_ "Runaway format");
642 FmLINES(PL_formtarget) = lines;
644 RETURNOP(cLISTOP->op_first);
657 while (*s && isSPACE(*s) && s < send)
661 arg = fieldsize - itemsize;
668 if (strnEQ(s," ",3)) {
669 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
680 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
681 FmLINES(PL_formtarget) += lines;
693 if (PL_stack_base + *PL_markstack_ptr == SP) {
695 if (GIMME_V == G_SCALAR)
696 XPUSHs(sv_2mortal(newSViv(0)));
697 RETURNOP(PL_op->op_next->op_next);
699 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
700 pp_pushmark(); /* push dst */
701 pp_pushmark(); /* push src */
702 ENTER; /* enter outer scope */
705 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
707 ENTER; /* enter inner scope */
710 src = PL_stack_base[*PL_markstack_ptr];
715 if (PL_op->op_type == OP_MAPSTART)
716 pp_pushmark(); /* push top */
717 return ((LOGOP*)PL_op->op_next)->op_other;
722 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
728 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
734 ++PL_markstack_ptr[-1];
736 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
737 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
738 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
743 PL_markstack_ptr[-1] += shift;
744 *PL_markstack_ptr += shift;
748 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
751 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
753 LEAVE; /* exit inner scope */
756 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
760 (void)POPMARK; /* pop top */
761 LEAVE; /* exit outer scope */
762 (void)POPMARK; /* pop src */
763 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
764 (void)POPMARK; /* pop dst */
765 SP = PL_stack_base + POPMARK; /* pop original mark */
766 if (gimme == G_SCALAR) {
770 else if (gimme == G_ARRAY)
777 ENTER; /* enter inner scope */
780 src = PL_stack_base[PL_markstack_ptr[-1]];
784 RETURNOP(cLOGOP->op_other);
790 djSP; dMARK; dORIGMARK;
792 SV **myorigmark = ORIGMARK;
798 OP* nextop = PL_op->op_next;
800 bool hasargs = FALSE;
803 if (gimme != G_ARRAY) {
809 SAVEVPTR(PL_sortcop);
810 if (PL_op->op_flags & OPf_STACKED) {
811 if (PL_op->op_flags & OPf_SPECIAL) {
812 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
813 kid = kUNOP->op_first; /* pass rv2gv */
814 kid = kUNOP->op_first; /* pass leave */
815 PL_sortcop = kid->op_next;
816 stash = CopSTASH(PL_curcop);
819 cv = sv_2cv(*++MARK, &stash, &gv, 0);
820 if (cv && SvPOK(cv)) {
822 char *proto = SvPV((SV*)cv, n_a);
823 if (proto && strEQ(proto, "$$")) {
827 if (!(cv && CvROOT(cv))) {
828 if (cv && CvXSUB(cv)) {
832 SV *tmpstr = sv_newmortal();
833 gv_efullname3(tmpstr, gv, Nullch);
834 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
838 DIE(aTHX_ "Undefined subroutine in sort");
843 PL_sortcop = (OP*)cv;
845 PL_sortcop = CvSTART(cv);
846 SAVEVPTR(CvROOT(cv)->op_ppaddr);
847 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
850 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
856 stash = CopSTASH(PL_curcop);
860 while (MARK < SP) { /* This may or may not shift down one here. */
862 if ((*up = *++MARK)) { /* Weed out nulls. */
864 if (!PL_sortcop && !SvPOK(*up)) {
869 (void)sv_2pv(*up, &n_a);
874 max = --up - myorigmark;
879 bool oldcatch = CATCH_GET;
885 PUSHSTACKi(PERLSI_SORT);
886 if (PL_sortstash != stash) {
887 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
888 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
889 PL_sortstash = stash;
892 SAVESPTR(GvSV(PL_firstgv));
893 SAVESPTR(GvSV(PL_secondgv));
895 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
896 if (!(PL_op->op_flags & OPf_SPECIAL)) {
897 cx->cx_type = CXt_SUB;
898 cx->blk_gimme = G_SCALAR;
901 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
903 PL_sortcxix = cxstack_ix;
905 if (hasargs && !is_xsub) {
906 /* This is mostly copied from pp_entersub */
907 AV *av = (AV*)PL_curpad[0];
910 cx->blk_sub.savearray = GvAV(PL_defgv);
911 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
912 #endif /* USE_THREADS */
913 cx->blk_sub.argarray = av;
915 qsortsv((myorigmark+1), max,
916 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
918 POPBLOCK(cx,PL_curpm);
926 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
927 qsortsv(ORIGMARK+1, max,
928 (PL_op->op_private & OPpSORT_NUMERIC)
929 ? ( (PL_op->op_private & OPpSORT_INTEGER)
930 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
931 : ( overloading ? amagic_ncmp : sv_ncmp))
932 : ( (PL_op->op_private & OPpLOCALE)
935 : sv_cmp_locale_static)
936 : ( overloading ? amagic_cmp : sv_cmp_static)));
937 if (PL_op->op_private & OPpSORT_REVERSE) {
939 SV **q = ORIGMARK+max;
949 PL_stack_sp = ORIGMARK + max;
957 if (GIMME == G_ARRAY)
959 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
960 return cLOGOP->op_other;
969 if (GIMME == G_ARRAY) {
970 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
974 SV *targ = PAD_SV(PL_op->op_targ);
976 if ((PL_op->op_private & OPpFLIP_LINENUM)
977 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
979 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
980 if (PL_op->op_flags & OPf_SPECIAL) {
988 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1001 if (GIMME == G_ARRAY) {
1007 if (SvGMAGICAL(left))
1009 if (SvGMAGICAL(right))
1012 if (SvNIOKp(left) || !SvPOKp(left) ||
1013 SvNIOKp(right) || !SvPOKp(right) ||
1014 (looks_like_number(left) && *SvPVX(left) != '0' &&
1015 looks_like_number(right) && *SvPVX(right) != '0'))
1017 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1018 DIE(aTHX_ "Range iterator outside integer range");
1029 sv = sv_2mortal(newSViv(i++));
1034 SV *final = sv_mortalcopy(right);
1036 char *tmps = SvPV(final, len);
1038 sv = sv_mortalcopy(left);
1040 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1042 if (strEQ(SvPVX(sv),tmps))
1044 sv = sv_2mortal(newSVsv(sv));
1051 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1053 if ((PL_op->op_private & OPpFLIP_LINENUM)
1054 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1056 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1057 sv_catpv(targ, "E0");
1068 S_dopoptolabel(pTHX_ char *label)
1072 register PERL_CONTEXT *cx;
1074 for (i = cxstack_ix; i >= 0; i--) {
1076 switch (CxTYPE(cx)) {
1078 if (ckWARN(WARN_EXITING))
1079 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1080 PL_op_name[PL_op->op_type]);
1083 if (ckWARN(WARN_EXITING))
1084 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1085 PL_op_name[PL_op->op_type]);
1088 if (ckWARN(WARN_EXITING))
1089 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1090 PL_op_name[PL_op->op_type]);
1093 if (ckWARN(WARN_EXITING))
1094 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1095 PL_op_name[PL_op->op_type]);
1098 if (ckWARN(WARN_EXITING))
1099 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1100 PL_op_name[PL_op->op_type]);
1103 if (!cx->blk_loop.label ||
1104 strNE(label, cx->blk_loop.label) ) {
1105 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1106 (long)i, cx->blk_loop.label));
1109 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1117 Perl_dowantarray(pTHX)
1119 I32 gimme = block_gimme();
1120 return (gimme == G_VOID) ? G_SCALAR : gimme;
1124 Perl_block_gimme(pTHX)
1129 cxix = dopoptosub(cxstack_ix);
1133 switch (cxstack[cxix].blk_gimme) {
1141 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1148 S_dopoptosub(pTHX_ I32 startingblock)
1151 return dopoptosub_at(cxstack, startingblock);
1155 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1159 register PERL_CONTEXT *cx;
1160 for (i = startingblock; i >= 0; i--) {
1162 switch (CxTYPE(cx)) {
1168 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1176 S_dopoptoeval(pTHX_ I32 startingblock)
1180 register PERL_CONTEXT *cx;
1181 for (i = startingblock; i >= 0; i--) {
1183 switch (CxTYPE(cx)) {
1187 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1195 S_dopoptoloop(pTHX_ I32 startingblock)
1199 register PERL_CONTEXT *cx;
1200 for (i = startingblock; i >= 0; i--) {
1202 switch (CxTYPE(cx)) {
1204 if (ckWARN(WARN_EXITING))
1205 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1206 PL_op_name[PL_op->op_type]);
1209 if (ckWARN(WARN_EXITING))
1210 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1211 PL_op_name[PL_op->op_type]);
1214 if (ckWARN(WARN_EXITING))
1215 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1216 PL_op_name[PL_op->op_type]);
1219 if (ckWARN(WARN_EXITING))
1220 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1221 PL_op_name[PL_op->op_type]);
1224 if (ckWARN(WARN_EXITING))
1225 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1226 PL_op_name[PL_op->op_type]);
1229 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1237 Perl_dounwind(pTHX_ I32 cxix)
1240 register PERL_CONTEXT *cx;
1243 while (cxstack_ix > cxix) {
1245 cx = &cxstack[cxstack_ix];
1246 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1247 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1248 /* Note: we don't need to restore the base context info till the end. */
1249 switch (CxTYPE(cx)) {
1252 continue; /* not break */
1274 * Closures mentioned at top level of eval cannot be referenced
1275 * again, and their presence indirectly causes a memory leak.
1276 * (Note that the fact that compcv and friends are still set here
1277 * is, AFAIK, an accident.) --Chip
1279 * XXX need to get comppad et al from eval's cv rather than
1280 * relying on the incidental global values.
1283 S_free_closures(pTHX)
1286 SV **svp = AvARRAY(PL_comppad_name);
1288 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1290 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1292 svp[ix] = &PL_sv_undef;
1296 SvREFCNT_dec(CvOUTSIDE(sv));
1297 CvOUTSIDE(sv) = Nullcv;
1310 Perl_qerror(pTHX_ SV *err)
1313 sv_catsv(ERRSV, err);
1315 sv_catsv(PL_errors, err);
1317 Perl_warn(aTHX_ "%"SVf, err);
1322 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1327 register PERL_CONTEXT *cx;
1332 if (PL_in_eval & EVAL_KEEPERR) {
1333 static char prefix[] = "\t(in cleanup) ";
1338 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1341 if (*e != *message || strNE(e,message))
1345 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1346 sv_catpvn(err, prefix, sizeof(prefix)-1);
1347 sv_catpvn(err, message, msglen);
1348 if (ckWARN(WARN_MISC)) {
1349 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1350 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1355 sv_setpvn(ERRSV, message, msglen);
1358 message = SvPVx(ERRSV, msglen);
1360 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1361 && PL_curstackinfo->si_prev)
1370 if (cxix < cxstack_ix)
1373 POPBLOCK(cx,PL_curpm);
1374 if (CxTYPE(cx) != CXt_EVAL) {
1375 PerlIO_write(Perl_error_log, "panic: die ", 11);
1376 PerlIO_write(Perl_error_log, message, msglen);
1381 if (gimme == G_SCALAR)
1382 *++newsp = &PL_sv_undef;
1383 PL_stack_sp = newsp;
1387 if (optype == OP_REQUIRE) {
1388 char* msg = SvPVx(ERRSV, n_a);
1389 DIE(aTHX_ "%sCompilation failed in require",
1390 *msg ? msg : "Unknown error\n");
1392 return pop_return();
1396 message = SvPVx(ERRSV, msglen);
1399 /* SFIO can really mess with your errno */
1402 PerlIO *serr = Perl_error_log;
1404 PerlIO_write(serr, message, msglen);
1405 (void)PerlIO_flush(serr);
1418 if (SvTRUE(left) != SvTRUE(right))
1430 RETURNOP(cLOGOP->op_other);
1439 RETURNOP(cLOGOP->op_other);
1445 register I32 cxix = dopoptosub(cxstack_ix);
1446 register PERL_CONTEXT *cx;
1447 register PERL_CONTEXT *ccstack = cxstack;
1448 PERL_SI *top_si = PL_curstackinfo;
1459 /* we may be in a higher stacklevel, so dig down deeper */
1460 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1461 top_si = top_si->si_prev;
1462 ccstack = top_si->si_cxstack;
1463 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1466 if (GIMME != G_ARRAY)
1470 if (PL_DBsub && cxix >= 0 &&
1471 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1475 cxix = dopoptosub_at(ccstack, cxix - 1);
1478 cx = &ccstack[cxix];
1479 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1480 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1481 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1482 field below is defined for any cx. */
1483 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1484 cx = &ccstack[dbcxix];
1487 stashname = CopSTASHPV(cx->blk_oldcop);
1488 if (GIMME != G_ARRAY) {
1490 PUSHs(&PL_sv_undef);
1493 sv_setpv(TARG, stashname);
1500 PUSHs(&PL_sv_undef);
1502 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1503 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1504 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1507 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1508 /* 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 /* try blocks have old_namesv == 0 */
1529 else if (cx->blk_eval.old_namesv) {
1530 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1535 PUSHs(&PL_sv_undef);
1536 PUSHs(&PL_sv_undef);
1538 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1539 && CopSTASH_eq(PL_curcop, 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;
1557 /* XXX only hints propagated via op_private are currently
1558 * visible (others are not easily accessible, since they
1559 * use the global PL_hints) */
1560 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1561 HINT_PRIVATE_MASK)));
1564 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1565 if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD)
1566 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1567 else if (old_warnings == pWARN_ALL)
1568 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1570 mask = newSVsv(old_warnings);
1571 PUSHs(sv_2mortal(mask));
1586 sv_reset(tmps, CopSTASH(PL_curcop));
1598 PL_curcop = (COP*)PL_op;
1599 TAINT_NOT; /* Each statement is presumed innocent */
1600 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1603 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1607 register PERL_CONTEXT *cx;
1608 I32 gimme = G_ARRAY;
1615 DIE(aTHX_ "No DB::DB routine defined");
1617 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1629 push_return(PL_op->op_next);
1630 PUSHBLOCK(cx, CXt_SUB, SP);
1633 (void)SvREFCNT_inc(cv);
1634 SAVEVPTR(PL_curpad);
1635 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1636 RETURNOP(CvSTART(cv));
1650 register PERL_CONTEXT *cx;
1651 I32 gimme = GIMME_V;
1653 U32 cxtype = CXt_LOOP;
1662 if (PL_op->op_flags & OPf_SPECIAL) {
1664 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1665 SAVEGENERICSV(*svp);
1669 #endif /* USE_THREADS */
1670 if (PL_op->op_targ) {
1671 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1674 iterdata = (void*)PL_op->op_targ;
1675 cxtype |= CXp_PADVAR;
1680 svp = &GvSV(gv); /* symbol table variable */
1681 SAVEGENERICSV(*svp);
1684 iterdata = (void*)gv;
1690 PUSHBLOCK(cx, cxtype, SP);
1692 PUSHLOOP(cx, iterdata, MARK);
1694 PUSHLOOP(cx, svp, MARK);
1696 if (PL_op->op_flags & OPf_STACKED) {
1697 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1698 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1700 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1701 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1702 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1703 looks_like_number((SV*)cx->blk_loop.iterary) &&
1704 *SvPVX(cx->blk_loop.iterary) != '0'))
1706 if (SvNV(sv) < IV_MIN ||
1707 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1708 DIE(aTHX_ "Range iterator outside integer range");
1709 cx->blk_loop.iterix = SvIV(sv);
1710 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1713 cx->blk_loop.iterlval = newSVsv(sv);
1717 cx->blk_loop.iterary = PL_curstack;
1718 AvFILLp(PL_curstack) = SP - PL_stack_base;
1719 cx->blk_loop.iterix = MARK - PL_stack_base;
1728 register PERL_CONTEXT *cx;
1729 I32 gimme = GIMME_V;
1735 PUSHBLOCK(cx, CXt_LOOP, SP);
1736 PUSHLOOP(cx, 0, SP);
1744 register PERL_CONTEXT *cx;
1752 newsp = PL_stack_base + cx->blk_loop.resetsp;
1755 if (gimme == G_VOID)
1757 else if (gimme == G_SCALAR) {
1759 *++newsp = sv_mortalcopy(*SP);
1761 *++newsp = &PL_sv_undef;
1765 *++newsp = sv_mortalcopy(*++mark);
1766 TAINT_NOT; /* Each item is independent */
1772 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1773 PL_curpm = newpm; /* ... and pop $1 et al */
1785 register PERL_CONTEXT *cx;
1786 bool popsub2 = FALSE;
1787 bool clear_errsv = FALSE;
1794 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1795 if (cxstack_ix == PL_sortcxix
1796 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1798 if (cxstack_ix > PL_sortcxix)
1799 dounwind(PL_sortcxix);
1800 AvARRAY(PL_curstack)[1] = *SP;
1801 PL_stack_sp = PL_stack_base + 1;
1806 cxix = dopoptosub(cxstack_ix);
1808 DIE(aTHX_ "Can't return outside a subroutine");
1809 if (cxix < cxstack_ix)
1813 switch (CxTYPE(cx)) {
1818 if (!(PL_in_eval & EVAL_KEEPERR))
1823 if (AvFILLp(PL_comppad_name) >= 0)
1826 if (optype == OP_REQUIRE &&
1827 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1829 /* Unassume the success we assumed earlier. */
1830 SV *nsv = cx->blk_eval.old_namesv;
1831 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1832 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1839 DIE(aTHX_ "panic: return");
1843 if (gimme == G_SCALAR) {
1846 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1848 *++newsp = SvREFCNT_inc(*SP);
1853 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1855 *++newsp = sv_mortalcopy(sv);
1860 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1863 *++newsp = sv_mortalcopy(*SP);
1866 *++newsp = &PL_sv_undef;
1868 else if (gimme == G_ARRAY) {
1869 while (++MARK <= SP) {
1870 *++newsp = (popsub2 && SvTEMP(*MARK))
1871 ? *MARK : sv_mortalcopy(*MARK);
1872 TAINT_NOT; /* Each item is independent */
1875 PL_stack_sp = newsp;
1877 /* Stack values are safe: */
1879 POPSUB(cx,sv); /* release CV and @_ ... */
1883 PL_curpm = newpm; /* ... and pop $1 et al */
1889 return pop_return();
1896 register PERL_CONTEXT *cx;
1906 if (PL_op->op_flags & OPf_SPECIAL) {
1907 cxix = dopoptoloop(cxstack_ix);
1909 DIE(aTHX_ "Can't \"last\" outside a loop block");
1912 cxix = dopoptolabel(cPVOP->op_pv);
1914 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1916 if (cxix < cxstack_ix)
1921 switch (CxTYPE(cx)) {
1924 newsp = PL_stack_base + cx->blk_loop.resetsp;
1925 nextop = cx->blk_loop.last_op->op_next;
1929 nextop = pop_return();
1933 nextop = pop_return();
1937 nextop = pop_return();
1940 DIE(aTHX_ "panic: last");
1944 if (gimme == G_SCALAR) {
1946 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1947 ? *SP : sv_mortalcopy(*SP);
1949 *++newsp = &PL_sv_undef;
1951 else if (gimme == G_ARRAY) {
1952 while (++MARK <= SP) {
1953 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1954 ? *MARK : sv_mortalcopy(*MARK);
1955 TAINT_NOT; /* Each item is independent */
1961 /* Stack values are safe: */
1964 POPLOOP(cx); /* release loop vars ... */
1968 POPSUB(cx,sv); /* release CV and @_ ... */
1971 PL_curpm = newpm; /* ... and pop $1 et al */
1981 register PERL_CONTEXT *cx;
1984 if (PL_op->op_flags & OPf_SPECIAL) {
1985 cxix = dopoptoloop(cxstack_ix);
1987 DIE(aTHX_ "Can't \"next\" outside a loop block");
1990 cxix = dopoptolabel(cPVOP->op_pv);
1992 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1994 if (cxix < cxstack_ix)
1999 /* clean scope, but only if there's no continue block */
2000 if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) {
2001 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2002 LEAVE_SCOPE(oldsave);
2004 return cx->blk_loop.next_op;
2010 register PERL_CONTEXT *cx;
2013 if (PL_op->op_flags & OPf_SPECIAL) {
2014 cxix = dopoptoloop(cxstack_ix);
2016 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2019 cxix = dopoptolabel(cPVOP->op_pv);
2021 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2023 if (cxix < cxstack_ix)
2027 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2028 LEAVE_SCOPE(oldsave);
2029 return cx->blk_loop.redo_op;
2033 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2037 static char too_deep[] = "Target of goto is too deeply nested";
2040 Perl_croak(aTHX_ too_deep);
2041 if (o->op_type == OP_LEAVE ||
2042 o->op_type == OP_SCOPE ||
2043 o->op_type == OP_LEAVELOOP ||
2044 o->op_type == OP_LEAVETRY)
2046 *ops++ = cUNOPo->op_first;
2048 Perl_croak(aTHX_ too_deep);
2051 if (o->op_flags & OPf_KIDS) {
2053 /* First try all the kids at this level, since that's likeliest. */
2054 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2055 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2056 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2059 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2060 if (kid == PL_lastgotoprobe)
2062 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2064 (ops[-1]->op_type != OP_NEXTSTATE &&
2065 ops[-1]->op_type != OP_DBSTATE)))
2067 if ((o = dofindlabel(kid, label, ops, oplimit)))
2086 register PERL_CONTEXT *cx;
2087 #define GOTO_DEPTH 64
2088 OP *enterops[GOTO_DEPTH];
2090 int do_dump = (PL_op->op_type == OP_DUMP);
2091 static char must_have_label[] = "goto must have label";
2094 if (PL_op->op_flags & OPf_STACKED) {
2098 /* This egregious kludge implements goto &subroutine */
2099 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2101 register PERL_CONTEXT *cx;
2102 CV* cv = (CV*)SvRV(sv);
2108 if (!CvROOT(cv) && !CvXSUB(cv)) {
2113 /* autoloaded stub? */
2114 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2116 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2117 GvNAMELEN(gv), FALSE);
2118 if (autogv && (cv = GvCV(autogv)))
2120 tmpstr = sv_newmortal();
2121 gv_efullname3(tmpstr, gv, Nullch);
2122 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2124 DIE(aTHX_ "Goto undefined subroutine");
2127 /* First do some returnish stuff. */
2128 cxix = dopoptosub(cxstack_ix);
2130 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2131 if (cxix < cxstack_ix)
2134 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2135 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2137 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2138 /* put @_ back onto stack */
2139 AV* av = cx->blk_sub.argarray;
2141 items = AvFILLp(av) + 1;
2143 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2144 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2145 PL_stack_sp += items;
2147 SvREFCNT_dec(GvAV(PL_defgv));
2148 GvAV(PL_defgv) = cx->blk_sub.savearray;
2149 #endif /* USE_THREADS */
2150 /* abandon @_ if it got reified */
2152 (void)sv_2mortal((SV*)av); /* delay until return */
2154 av_extend(av, items-1);
2155 AvFLAGS(av) = AVf_REIFY;
2156 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2159 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2162 av = (AV*)PL_curpad[0];
2164 av = GvAV(PL_defgv);
2166 items = AvFILLp(av) + 1;
2168 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2169 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2170 PL_stack_sp += items;
2172 if (CxTYPE(cx) == CXt_SUB &&
2173 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2174 SvREFCNT_dec(cx->blk_sub.cv);
2175 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2176 LEAVE_SCOPE(oldsave);
2178 /* Now do some callish stuff. */
2181 #ifdef PERL_XSUB_OLDSTYLE
2182 if (CvOLDSTYLE(cv)) {
2183 I32 (*fp3)(int,int,int);
2188 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2189 items = (*fp3)(CvXSUBANY(cv).any_i32,
2190 mark - PL_stack_base + 1,
2192 SP = PL_stack_base + items;
2195 #endif /* PERL_XSUB_OLDSTYLE */
2200 PL_stack_sp--; /* There is no cv arg. */
2201 /* Push a mark for the start of arglist */
2203 (void)(*CvXSUB(cv))(aTHXo_ cv);
2204 /* Pop the current context like a decent sub should */
2205 POPBLOCK(cx, PL_curpm);
2206 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2209 return pop_return();
2212 AV* padlist = CvPADLIST(cv);
2213 SV** svp = AvARRAY(padlist);
2214 if (CxTYPE(cx) == CXt_EVAL) {
2215 PL_in_eval = cx->blk_eval.old_in_eval;
2216 PL_eval_root = cx->blk_eval.old_eval_root;
2217 cx->cx_type = CXt_SUB;
2218 cx->blk_sub.hasargs = 0;
2220 cx->blk_sub.cv = cv;
2221 cx->blk_sub.olddepth = CvDEPTH(cv);
2223 if (CvDEPTH(cv) < 2)
2224 (void)SvREFCNT_inc(cv);
2225 else { /* save temporaries on recursion? */
2226 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2227 sub_crush_depth(cv);
2228 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2229 AV *newpad = newAV();
2230 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2231 I32 ix = AvFILLp((AV*)svp[1]);
2232 I32 names_fill = AvFILLp((AV*)svp[0]);
2233 svp = AvARRAY(svp[0]);
2234 for ( ;ix > 0; ix--) {
2235 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2236 char *name = SvPVX(svp[ix]);
2237 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2240 /* outer lexical or anon code */
2241 av_store(newpad, ix,
2242 SvREFCNT_inc(oldpad[ix]) );
2244 else { /* our own lexical */
2246 av_store(newpad, ix, sv = (SV*)newAV());
2247 else if (*name == '%')
2248 av_store(newpad, ix, sv = (SV*)newHV());
2250 av_store(newpad, ix, sv = NEWSV(0,0));
2254 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2255 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2258 av_store(newpad, ix, sv = NEWSV(0,0));
2262 if (cx->blk_sub.hasargs) {
2265 av_store(newpad, 0, (SV*)av);
2266 AvFLAGS(av) = AVf_REIFY;
2268 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2269 AvFILLp(padlist) = CvDEPTH(cv);
2270 svp = AvARRAY(padlist);
2274 if (!cx->blk_sub.hasargs) {
2275 AV* av = (AV*)PL_curpad[0];
2277 items = AvFILLp(av) + 1;
2279 /* Mark is at the end of the stack. */
2281 Copy(AvARRAY(av), SP + 1, items, SV*);
2286 #endif /* USE_THREADS */
2287 SAVEVPTR(PL_curpad);
2288 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2290 if (cx->blk_sub.hasargs)
2291 #endif /* USE_THREADS */
2293 AV* av = (AV*)PL_curpad[0];
2297 cx->blk_sub.savearray = GvAV(PL_defgv);
2298 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2299 #endif /* USE_THREADS */
2300 cx->blk_sub.argarray = av;
2303 if (items >= AvMAX(av) + 1) {
2305 if (AvARRAY(av) != ary) {
2306 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2307 SvPVX(av) = (char*)ary;
2309 if (items >= AvMAX(av) + 1) {
2310 AvMAX(av) = items - 1;
2311 Renew(ary,items+1,SV*);
2313 SvPVX(av) = (char*)ary;
2316 Copy(mark,AvARRAY(av),items,SV*);
2317 AvFILLp(av) = items - 1;
2318 assert(!AvREAL(av));
2325 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2327 * We do not care about using sv to call CV;
2328 * it's for informational purposes only.
2330 SV *sv = GvSV(PL_DBsub);
2333 if (PERLDB_SUB_NN) {
2334 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2337 gv_efullname3(sv, CvGV(cv), Nullch);
2340 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2341 PUSHMARK( PL_stack_sp );
2342 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2346 RETURNOP(CvSTART(cv));
2350 label = SvPV(sv,n_a);
2351 if (!(do_dump || *label))
2352 DIE(aTHX_ must_have_label);
2355 else if (PL_op->op_flags & OPf_SPECIAL) {
2357 DIE(aTHX_ must_have_label);
2360 label = cPVOP->op_pv;
2362 if (label && *label) {
2367 PL_lastgotoprobe = 0;
2369 for (ix = cxstack_ix; ix >= 0; ix--) {
2371 switch (CxTYPE(cx)) {
2373 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2376 gotoprobe = cx->blk_oldcop->op_sibling;
2382 gotoprobe = cx->blk_oldcop->op_sibling;
2384 gotoprobe = PL_main_root;
2387 if (CvDEPTH(cx->blk_sub.cv)) {
2388 gotoprobe = CvROOT(cx->blk_sub.cv);
2394 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2397 DIE(aTHX_ "panic: goto");
2398 gotoprobe = PL_main_root;
2402 retop = dofindlabel(gotoprobe, label,
2403 enterops, enterops + GOTO_DEPTH);
2407 PL_lastgotoprobe = gotoprobe;
2410 DIE(aTHX_ "Can't find label %s", label);
2412 /* pop unwanted frames */
2414 if (ix < cxstack_ix) {
2421 oldsave = PL_scopestack[PL_scopestack_ix];
2422 LEAVE_SCOPE(oldsave);
2425 /* push wanted frames */
2427 if (*enterops && enterops[1]) {
2429 for (ix = 1; enterops[ix]; ix++) {
2430 PL_op = enterops[ix];
2431 /* Eventually we may want to stack the needed arguments
2432 * for each op. For now, we punt on the hard ones. */
2433 if (PL_op->op_type == OP_ENTERITER)
2434 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2435 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2443 if (!retop) retop = PL_main_start;
2445 PL_restartop = retop;
2446 PL_do_undump = TRUE;
2450 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2451 PL_do_undump = FALSE;
2467 if (anum == 1 && VMSISH_EXIT)
2471 PL_exit_flags |= PERL_EXIT_EXPECTED;
2473 PUSHs(&PL_sv_undef);
2481 NV value = SvNVx(GvSV(cCOP->cop_gv));
2482 register I32 match = I_32(value);
2485 if (((NV)match) > value)
2486 --match; /* was fractional--truncate other way */
2488 match -= cCOP->uop.scop.scop_offset;
2491 else if (match > cCOP->uop.scop.scop_max)
2492 match = cCOP->uop.scop.scop_max;
2493 PL_op = cCOP->uop.scop.scop_next[match];
2503 PL_op = PL_op->op_next; /* can't assume anything */
2506 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2507 match -= cCOP->uop.scop.scop_offset;
2510 else if (match > cCOP->uop.scop.scop_max)
2511 match = cCOP->uop.scop.scop_max;
2512 PL_op = cCOP->uop.scop.scop_next[match];
2521 S_save_lines(pTHX_ AV *array, SV *sv)
2523 register char *s = SvPVX(sv);
2524 register char *send = SvPVX(sv) + SvCUR(sv);
2526 register I32 line = 1;
2528 while (s && s < send) {
2529 SV *tmpstr = NEWSV(85,0);
2531 sv_upgrade(tmpstr, SVt_PVMG);
2532 t = strchr(s, '\n');
2538 sv_setpvn(tmpstr, s, t - s);
2539 av_store(array, line++, tmpstr);
2544 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2546 S_docatch_body(pTHX_ va_list args)
2548 return docatch_body();
2553 S_docatch_body(pTHX)
2560 S_docatch(pTHX_ OP *o)
2565 volatile PERL_SI *cursi = PL_curstackinfo;
2569 assert(CATCH_GET == TRUE);
2572 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2574 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2580 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2586 if (PL_restartop && cursi == PL_curstackinfo) {
2587 PL_op = PL_restartop;
2604 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2605 /* sv Text to convert to OP tree. */
2606 /* startop op_free() this to undo. */
2607 /* code Short string id of the caller. */
2609 dSP; /* Make POPBLOCK work. */
2612 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2616 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2617 char *tmpbuf = tbuf;
2623 /* switch to eval mode */
2625 if (PL_curcop == &PL_compiling) {
2626 SAVECOPSTASH(&PL_compiling);
2627 CopSTASH_set(&PL_compiling, PL_curstash);
2629 SAVECOPFILE(&PL_compiling);
2630 SAVECOPLINE(&PL_compiling);
2631 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2632 SV *sv = sv_newmortal();
2633 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2634 code, (unsigned long)++PL_evalseq,
2635 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2639 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2640 CopFILE_set(&PL_compiling, tmpbuf+2);
2641 CopLINE_set(&PL_compiling, 1);
2642 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2643 deleting the eval's FILEGV from the stash before gv_check() runs
2644 (i.e. before run-time proper). To work around the coredump that
2645 ensues, we always turn GvMULTI_on for any globals that were
2646 introduced within evals. See force_ident(). GSAR 96-10-12 */
2647 safestr = savepv(tmpbuf);
2648 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2650 #ifdef OP_IN_REGISTER
2658 PL_op->op_type = OP_ENTEREVAL;
2659 PL_op->op_flags = 0; /* Avoid uninit warning. */
2660 PUSHBLOCK(cx, CXt_EVAL, SP);
2661 PUSHEVAL(cx, 0, Nullgv);
2662 rop = doeval(G_SCALAR, startop);
2663 POPBLOCK(cx,PL_curpm);
2666 (*startop)->op_type = OP_NULL;
2667 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2669 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2671 if (PL_curcop == &PL_compiling)
2672 PL_compiling.op_private = PL_hints;
2673 #ifdef OP_IN_REGISTER
2679 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2681 S_doeval(pTHX_ int gimme, OP** startop)
2689 PL_in_eval = EVAL_INEVAL;
2693 /* set up a scratch pad */
2696 SAVEVPTR(PL_curpad);
2697 SAVESPTR(PL_comppad);
2698 SAVESPTR(PL_comppad_name);
2699 SAVEI32(PL_comppad_name_fill);
2700 SAVEI32(PL_min_intro_pending);
2701 SAVEI32(PL_max_intro_pending);
2704 for (i = cxstack_ix - 1; i >= 0; i--) {
2705 PERL_CONTEXT *cx = &cxstack[i];
2706 if (CxTYPE(cx) == CXt_EVAL)
2708 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2709 caller = cx->blk_sub.cv;
2714 SAVESPTR(PL_compcv);
2715 PL_compcv = (CV*)NEWSV(1104,0);
2716 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2717 CvEVAL_on(PL_compcv);
2719 CvOWNER(PL_compcv) = 0;
2720 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2721 MUTEX_INIT(CvMUTEXP(PL_compcv));
2722 #endif /* USE_THREADS */
2724 PL_comppad = newAV();
2725 av_push(PL_comppad, Nullsv);
2726 PL_curpad = AvARRAY(PL_comppad);
2727 PL_comppad_name = newAV();
2728 PL_comppad_name_fill = 0;
2729 PL_min_intro_pending = 0;
2732 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2733 PL_curpad[0] = (SV*)newAV();
2734 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2735 #endif /* USE_THREADS */
2737 comppadlist = newAV();
2738 AvREAL_off(comppadlist);
2739 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2740 av_store(comppadlist, 1, (SV*)PL_comppad);
2741 CvPADLIST(PL_compcv) = comppadlist;
2744 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2746 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2749 SAVEFREESV(PL_compcv);
2751 /* make sure we compile in the right package */
2753 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2754 SAVESPTR(PL_curstash);
2755 PL_curstash = CopSTASH(PL_curcop);
2757 SAVESPTR(PL_beginav);
2758 PL_beginav = newAV();
2759 SAVEFREESV(PL_beginav);
2761 /* try to compile it */
2763 PL_eval_root = Nullop;
2765 PL_curcop = &PL_compiling;
2766 PL_curcop->cop_arybase = 0;
2767 SvREFCNT_dec(PL_rs);
2768 PL_rs = newSVpvn("\n", 1);
2769 if (saveop && saveop->op_flags & OPf_SPECIAL)
2770 PL_in_eval |= EVAL_KEEPERR;
2773 if (yyparse() || PL_error_count || !PL_eval_root) {
2777 I32 optype = 0; /* Might be reset by POPEVAL. */
2782 op_free(PL_eval_root);
2783 PL_eval_root = Nullop;
2785 SP = PL_stack_base + POPMARK; /* pop original mark */
2787 POPBLOCK(cx,PL_curpm);
2793 if (optype == OP_REQUIRE) {
2794 char* msg = SvPVx(ERRSV, n_a);
2795 DIE(aTHX_ "%sCompilation failed in require",
2796 *msg ? msg : "Unknown error\n");
2799 char* msg = SvPVx(ERRSV, n_a);
2801 POPBLOCK(cx,PL_curpm);
2803 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2804 (*msg ? msg : "Unknown error\n"));
2806 SvREFCNT_dec(PL_rs);
2807 PL_rs = SvREFCNT_inc(PL_nrs);
2809 MUTEX_LOCK(&PL_eval_mutex);
2811 COND_SIGNAL(&PL_eval_cond);
2812 MUTEX_UNLOCK(&PL_eval_mutex);
2813 #endif /* USE_THREADS */
2816 SvREFCNT_dec(PL_rs);
2817 PL_rs = SvREFCNT_inc(PL_nrs);
2818 CopLINE_set(&PL_compiling, 0);
2820 *startop = PL_eval_root;
2821 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2822 CvOUTSIDE(PL_compcv) = Nullcv;
2824 SAVEFREEOP(PL_eval_root);
2826 scalarvoid(PL_eval_root);
2827 else if (gimme & G_ARRAY)
2830 scalar(PL_eval_root);
2832 DEBUG_x(dump_eval());
2834 /* Register with debugger: */
2835 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2836 CV *cv = get_cv("DB::postponed", FALSE);
2840 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2842 call_sv((SV*)cv, G_DISCARD);
2846 /* compiled okay, so do it */
2848 CvDEPTH(PL_compcv) = 1;
2849 SP = PL_stack_base + POPMARK; /* pop original mark */
2850 PL_op = saveop; /* The caller may need it. */
2852 MUTEX_LOCK(&PL_eval_mutex);
2854 COND_SIGNAL(&PL_eval_cond);
2855 MUTEX_UNLOCK(&PL_eval_mutex);
2856 #endif /* USE_THREADS */
2858 RETURNOP(PL_eval_start);
2862 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2864 STRLEN namelen = strlen(name);
2867 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2868 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2869 char *pmc = SvPV_nolen(pmcsv);
2872 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2873 fp = PerlIO_open(name, mode);
2876 if (PerlLIO_stat(name, &pmstat) < 0 ||
2877 pmstat.st_mtime < pmcstat.st_mtime)
2879 fp = PerlIO_open(pmc, mode);
2882 fp = PerlIO_open(name, mode);
2885 SvREFCNT_dec(pmcsv);
2888 fp = PerlIO_open(name, mode);
2896 register PERL_CONTEXT *cx;
2901 SV *namesv = Nullsv;
2903 I32 gimme = G_SCALAR;
2904 PerlIO *tryrsfp = 0;
2906 int filter_has_file = 0;
2907 GV *filter_child_proc = 0;
2908 SV *filter_state = 0;
2914 if (SvPOKp(sv)) { /* require v5.6.1 */
2916 U8 *s = (U8*)SvPVX(sv);
2917 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2919 rev = utf8_to_uv(s, &len);
2922 ver = utf8_to_uv(s, &len);
2925 sver = utf8_to_uv(s, &len);
2934 if (PERL_REVISION < rev
2935 || (PERL_REVISION == rev
2936 && (PERL_VERSION < ver
2937 || (PERL_VERSION == ver
2938 && PERL_SUBVERSION < sver))))
2940 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2941 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2942 PERL_VERSION, PERL_SUBVERSION);
2945 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2946 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2947 + ((NV)PERL_SUBVERSION/(NV)1000000)
2948 + 0.00000099 < SvNV(sv))
2952 NV nver = (nrev - rev) * 1000;
2953 UV ver = (UV)(nver + 0.0009);
2954 NV nsver = (nver - ver) * 1000;
2955 UV sver = (UV)(nsver + 0.0009);
2957 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2958 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2959 PERL_VERSION, PERL_SUBVERSION);
2964 name = SvPV(sv, len);
2965 if (!(name && len > 0 && *name))
2966 DIE(aTHX_ "Null filename used");
2967 TAINT_PROPER("require");
2968 if (PL_op->op_type == OP_REQUIRE &&
2969 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2970 *svp != &PL_sv_undef)
2973 /* prepare to compile file */
2975 if (PERL_FILE_IS_ABSOLUTE(name)
2976 || (*name == '.' && (name[1] == '/' ||
2977 (name[1] == '.' && name[2] == '/'))))
2980 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2983 AV *ar = GvAVn(PL_incgv);
2987 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2990 namesv = NEWSV(806, 0);
2991 for (i = 0; i <= AvFILL(ar); i++) {
2992 SV *dirsv = *av_fetch(ar, i, TRUE);
2998 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2999 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3002 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3003 PTR2UV(SvANY(loader)), name);
3004 tryname = SvPVX(namesv);
3015 count = call_sv(loader, G_ARRAY);
3025 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3029 if (SvTYPE(arg) == SVt_PVGV) {
3030 IO *io = GvIO((GV *)arg);
3035 tryrsfp = IoIFP(io);
3036 if (IoTYPE(io) == '|') {
3037 /* reading from a child process doesn't
3038 nest -- when returning from reading
3039 the inner module, the outer one is
3040 unreadable (closed?) I've tried to
3041 save the gv to manage the lifespan of
3042 the pipe, but this didn't help. XXX */
3043 filter_child_proc = (GV *)arg;
3044 (void)SvREFCNT_inc(filter_child_proc);
3047 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3048 PerlIO_close(IoOFP(io));
3060 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3062 (void)SvREFCNT_inc(filter_sub);
3065 filter_state = SP[i];
3066 (void)SvREFCNT_inc(filter_state);
3070 tryrsfp = PerlIO_open("/dev/null",
3084 filter_has_file = 0;
3085 if (filter_child_proc) {
3086 SvREFCNT_dec(filter_child_proc);
3087 filter_child_proc = 0;
3090 SvREFCNT_dec(filter_state);
3094 SvREFCNT_dec(filter_sub);
3099 char *dir = SvPVx(dirsv, n_a);
3102 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3104 sv_setpv(namesv, unixdir);
3105 sv_catpv(namesv, unixname);
3107 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3109 TAINT_PROPER("require");
3110 tryname = SvPVX(namesv);
3111 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3113 if (tryname[0] == '.' && tryname[1] == '/')
3121 SAVECOPFILE(&PL_compiling);
3122 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3123 SvREFCNT_dec(namesv);
3125 if (PL_op->op_type == OP_REQUIRE) {
3126 char *msgstr = name;
3127 if (namesv) { /* did we lookup @INC? */
3128 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3129 SV *dirmsgsv = NEWSV(0, 0);
3130 AV *ar = GvAVn(PL_incgv);
3132 sv_catpvn(msg, " in @INC", 8);
3133 if (instr(SvPVX(msg), ".h "))
3134 sv_catpv(msg, " (change .h to .ph maybe?)");
3135 if (instr(SvPVX(msg), ".ph "))
3136 sv_catpv(msg, " (did you run h2ph?)");
3137 sv_catpv(msg, " (@INC contains:");
3138 for (i = 0; i <= AvFILL(ar); i++) {
3139 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3140 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3141 sv_catsv(msg, dirmsgsv);
3143 sv_catpvn(msg, ")", 1);
3144 SvREFCNT_dec(dirmsgsv);
3145 msgstr = SvPV_nolen(msg);
3147 DIE(aTHX_ "Can't locate %s", msgstr);
3153 SETERRNO(0, SS$_NORMAL);
3155 /* Assume success here to prevent recursive requirement. */
3156 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3157 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3161 lex_start(sv_2mortal(newSVpvn("",0)));
3162 SAVEGENERICSV(PL_rsfp_filters);
3163 PL_rsfp_filters = Nullav;
3168 SAVESPTR(PL_compiling.cop_warnings);
3169 if (PL_dowarn & G_WARN_ALL_ON)
3170 PL_compiling.cop_warnings = pWARN_ALL ;
3171 else if (PL_dowarn & G_WARN_ALL_OFF)
3172 PL_compiling.cop_warnings = pWARN_NONE ;
3174 PL_compiling.cop_warnings = pWARN_STD ;
3176 if (filter_sub || filter_child_proc) {
3177 SV *datasv = filter_add(run_user_filter, Nullsv);
3178 IoLINES(datasv) = filter_has_file;
3179 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3180 IoTOP_GV(datasv) = (GV *)filter_state;
3181 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3184 /* switch to eval mode */
3185 push_return(PL_op->op_next);
3186 PUSHBLOCK(cx, CXt_EVAL, SP);
3187 PUSHEVAL(cx, name, Nullgv);
3189 SAVECOPLINE(&PL_compiling);
3190 CopLINE_set(&PL_compiling, 0);
3194 MUTEX_LOCK(&PL_eval_mutex);
3195 if (PL_eval_owner && PL_eval_owner != thr)
3196 while (PL_eval_owner)
3197 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3198 PL_eval_owner = thr;
3199 MUTEX_UNLOCK(&PL_eval_mutex);
3200 #endif /* USE_THREADS */
3201 return DOCATCH(doeval(G_SCALAR, NULL));
3206 return pp_require();
3212 register PERL_CONTEXT *cx;
3214 I32 gimme = GIMME_V, was = PL_sub_generation;
3215 char tbuf[TYPE_DIGITS(long) + 12];
3216 char *tmpbuf = tbuf;
3221 if (!SvPV(sv,len) || !len)
3223 TAINT_PROPER("eval");
3229 /* switch to eval mode */
3231 SAVECOPFILE(&PL_compiling);
3232 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3233 SV *sv = sv_newmortal();
3234 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3235 (unsigned long)++PL_evalseq,
3236 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3240 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3241 CopFILE_set(&PL_compiling, tmpbuf+2);
3242 CopLINE_set(&PL_compiling, 1);
3243 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3244 deleting the eval's FILEGV from the stash before gv_check() runs
3245 (i.e. before run-time proper). To work around the coredump that
3246 ensues, we always turn GvMULTI_on for any globals that were
3247 introduced within evals. See force_ident(). GSAR 96-10-12 */
3248 safestr = savepv(tmpbuf);
3249 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3251 PL_hints = PL_op->op_targ;
3252 SAVESPTR(PL_compiling.cop_warnings);
3253 if (!specialWARN(PL_compiling.cop_warnings)) {
3254 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3255 SAVEFREESV(PL_compiling.cop_warnings) ;
3258 push_return(PL_op->op_next);
3259 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3260 PUSHEVAL(cx, 0, Nullgv);
3262 /* prepare to compile string */
3264 if (PERLDB_LINE && PL_curstash != PL_debstash)
3265 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3268 MUTEX_LOCK(&PL_eval_mutex);
3269 if (PL_eval_owner && PL_eval_owner != thr)
3270 while (PL_eval_owner)
3271 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3272 PL_eval_owner = thr;
3273 MUTEX_UNLOCK(&PL_eval_mutex);
3274 #endif /* USE_THREADS */
3275 ret = doeval(gimme, NULL);
3276 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3277 && ret != PL_op->op_next) { /* Successive compilation. */
3278 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3280 return DOCATCH(ret);
3290 register PERL_CONTEXT *cx;
3292 U8 save_flags = PL_op -> op_flags;
3297 retop = pop_return();
3300 if (gimme == G_VOID)
3302 else if (gimme == G_SCALAR) {
3305 if (SvFLAGS(TOPs) & SVs_TEMP)
3308 *MARK = sv_mortalcopy(TOPs);
3312 *MARK = &PL_sv_undef;
3317 /* in case LEAVE wipes old return values */
3318 for (mark = newsp + 1; mark <= SP; mark++) {
3319 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3320 *mark = sv_mortalcopy(*mark);
3321 TAINT_NOT; /* Each item is independent */
3325 PL_curpm = newpm; /* Don't pop $1 et al till now */
3327 if (AvFILLp(PL_comppad_name) >= 0)
3331 assert(CvDEPTH(PL_compcv) == 1);
3333 CvDEPTH(PL_compcv) = 0;
3336 if (optype == OP_REQUIRE &&
3337 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3339 /* Unassume the success we assumed earlier. */
3340 SV *nsv = cx->blk_eval.old_namesv;
3341 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3342 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3343 /* die_where() did LEAVE, or we won't be here */
3347 if (!(save_flags & OPf_SPECIAL))
3357 register PERL_CONTEXT *cx;
3358 I32 gimme = GIMME_V;
3363 push_return(cLOGOP->op_other->op_next);
3364 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3366 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3368 PL_in_eval = EVAL_INEVAL;
3371 return DOCATCH(PL_op->op_next);
3381 register PERL_CONTEXT *cx;
3389 if (gimme == G_VOID)
3391 else if (gimme == G_SCALAR) {
3394 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3397 *MARK = sv_mortalcopy(TOPs);
3401 *MARK = &PL_sv_undef;
3406 /* in case LEAVE wipes old return values */
3407 for (mark = newsp + 1; mark <= SP; mark++) {
3408 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3409 *mark = sv_mortalcopy(*mark);
3410 TAINT_NOT; /* Each item is independent */
3414 PL_curpm = newpm; /* Don't pop $1 et al till now */
3422 S_doparseform(pTHX_ SV *sv)
3425 register char *s = SvPV_force(sv, len);
3426 register char *send = s + len;
3427 register char *base;
3428 register I32 skipspaces = 0;
3431 bool postspace = FALSE;
3439 Perl_croak(aTHX_ "Null picture in formline");
3441 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3446 *fpc++ = FF_LINEMARK;
3447 noblank = repeat = FALSE;
3465 case ' ': case '\t':
3476 *fpc++ = FF_LITERAL;
3484 *fpc++ = skipspaces;
3488 *fpc++ = FF_NEWLINE;
3492 arg = fpc - linepc + 1;
3499 *fpc++ = FF_LINEMARK;
3500 noblank = repeat = FALSE;
3509 ischop = s[-1] == '^';
3515 arg = (s - base) - 1;
3517 *fpc++ = FF_LITERAL;
3526 *fpc++ = FF_LINEGLOB;
3528 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3529 arg = ischop ? 512 : 0;
3539 arg |= 256 + (s - f);
3541 *fpc++ = s - base; /* fieldsize for FETCH */
3542 *fpc++ = FF_DECIMAL;
3547 bool ismore = FALSE;
3550 while (*++s == '>') ;
3551 prespace = FF_SPACE;
3553 else if (*s == '|') {
3554 while (*++s == '|') ;
3555 prespace = FF_HALFSPACE;
3560 while (*++s == '<') ;
3563 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3567 *fpc++ = s - base; /* fieldsize for FETCH */
3569 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3587 { /* need to jump to the next word */
3589 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3590 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3591 s = SvPVX(sv) + SvCUR(sv) + z;
3593 Copy(fops, s, arg, U16);
3595 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3600 * The rest of this file was derived from source code contributed
3603 * NOTE: this code was derived from Tom Horsley's qsort replacement
3604 * and should not be confused with the original code.
3607 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3609 Permission granted to distribute under the same terms as perl which are
3612 This program is free software; you can redistribute it and/or modify
3613 it under the terms of either:
3615 a) the GNU General Public License as published by the Free
3616 Software Foundation; either version 1, or (at your option) any
3619 b) the "Artistic License" which comes with this Kit.
3621 Details on the perl license can be found in the perl source code which
3622 may be located via the www.perl.com web page.
3624 This is the most wonderfulest possible qsort I can come up with (and
3625 still be mostly portable) My (limited) tests indicate it consistently
3626 does about 20% fewer calls to compare than does the qsort in the Visual
3627 C++ library, other vendors may vary.
3629 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3630 others I invented myself (or more likely re-invented since they seemed
3631 pretty obvious once I watched the algorithm operate for a while).
3633 Most of this code was written while watching the Marlins sweep the Giants
3634 in the 1997 National League Playoffs - no Braves fans allowed to use this
3635 code (just kidding :-).
3637 I realize that if I wanted to be true to the perl tradition, the only
3638 comment in this file would be something like:
3640 ...they shuffled back towards the rear of the line. 'No, not at the
3641 rear!' the slave-driver shouted. 'Three files up. And stay there...
3643 However, I really needed to violate that tradition just so I could keep
3644 track of what happens myself, not to mention some poor fool trying to
3645 understand this years from now :-).
3648 /* ********************************************************** Configuration */
3650 #ifndef QSORT_ORDER_GUESS
3651 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3654 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3655 future processing - a good max upper bound is log base 2 of memory size
3656 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3657 safely be smaller than that since the program is taking up some space and
3658 most operating systems only let you grab some subset of contiguous
3659 memory (not to mention that you are normally sorting data larger than
3660 1 byte element size :-).
3662 #ifndef QSORT_MAX_STACK
3663 #define QSORT_MAX_STACK 32
3666 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3667 Anything bigger and we use qsort. If you make this too small, the qsort
3668 will probably break (or become less efficient), because it doesn't expect
3669 the middle element of a partition to be the same as the right or left -
3670 you have been warned).
3672 #ifndef QSORT_BREAK_EVEN
3673 #define QSORT_BREAK_EVEN 6
3676 /* ************************************************************* Data Types */
3678 /* hold left and right index values of a partition waiting to be sorted (the
3679 partition includes both left and right - right is NOT one past the end or
3680 anything like that).
3682 struct partition_stack_entry {
3685 #ifdef QSORT_ORDER_GUESS
3686 int qsort_break_even;
3690 /* ******************************************************* Shorthand Macros */
3692 /* Note that these macros will be used from inside the qsort function where
3693 we happen to know that the variable 'elt_size' contains the size of an
3694 array element and the variable 'temp' points to enough space to hold a
3695 temp element and the variable 'array' points to the array being sorted
3696 and 'compare' is the pointer to the compare routine.
3698 Also note that there are very many highly architecture specific ways
3699 these might be sped up, but this is simply the most generally portable
3700 code I could think of.
3703 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3705 #define qsort_cmp(elt1, elt2) \
3706 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3708 #ifdef QSORT_ORDER_GUESS
3709 #define QSORT_NOTICE_SWAP swapped++;
3711 #define QSORT_NOTICE_SWAP
3714 /* swaps contents of array elements elt1, elt2.
3716 #define qsort_swap(elt1, elt2) \
3719 temp = array[elt1]; \
3720 array[elt1] = array[elt2]; \
3721 array[elt2] = temp; \
3724 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3725 elt3 and elt3 gets elt1.
3727 #define qsort_rotate(elt1, elt2, elt3) \
3730 temp = array[elt1]; \
3731 array[elt1] = array[elt2]; \
3732 array[elt2] = array[elt3]; \
3733 array[elt3] = temp; \
3736 /* ************************************************************ Debug stuff */
3743 return; /* good place to set a breakpoint */
3746 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3749 doqsort_all_asserts(
3753 int (*compare)(const void * elt1, const void * elt2),
3754 int pc_left, int pc_right, int u_left, int u_right)
3758 qsort_assert(pc_left <= pc_right);
3759 qsort_assert(u_right < pc_left);
3760 qsort_assert(pc_right < u_left);
3761 for (i = u_right + 1; i < pc_left; ++i) {
3762 qsort_assert(qsort_cmp(i, pc_left) < 0);
3764 for (i = pc_left; i < pc_right; ++i) {
3765 qsort_assert(qsort_cmp(i, pc_right) == 0);
3767 for (i = pc_right + 1; i < u_left; ++i) {
3768 qsort_assert(qsort_cmp(pc_right, i) < 0);
3772 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3773 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3774 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3778 #define qsort_assert(t) ((void)0)
3780 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3784 /* ****************************************************************** qsort */
3787 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3791 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3792 int next_stack_entry = 0;
3796 #ifdef QSORT_ORDER_GUESS
3797 int qsort_break_even;
3801 /* Make sure we actually have work to do.
3803 if (num_elts <= 1) {
3807 /* Setup the initial partition definition and fall into the sorting loop
3810 part_right = (int)(num_elts - 1);
3811 #ifdef QSORT_ORDER_GUESS
3812 qsort_break_even = QSORT_BREAK_EVEN;
3814 #define qsort_break_even QSORT_BREAK_EVEN
3817 if ((part_right - part_left) >= qsort_break_even) {
3818 /* OK, this is gonna get hairy, so lets try to document all the
3819 concepts and abbreviations and variables and what they keep
3822 pc: pivot chunk - the set of array elements we accumulate in the
3823 middle of the partition, all equal in value to the original
3824 pivot element selected. The pc is defined by:
3826 pc_left - the leftmost array index of the pc
3827 pc_right - the rightmost array index of the pc
3829 we start with pc_left == pc_right and only one element
3830 in the pivot chunk (but it can grow during the scan).
3832 u: uncompared elements - the set of elements in the partition
3833 we have not yet compared to the pivot value. There are two
3834 uncompared sets during the scan - one to the left of the pc
3835 and one to the right.
3837 u_right - the rightmost index of the left side's uncompared set
3838 u_left - the leftmost index of the right side's uncompared set
3840 The leftmost index of the left sides's uncompared set
3841 doesn't need its own variable because it is always defined
3842 by the leftmost edge of the whole partition (part_left). The
3843 same goes for the rightmost edge of the right partition
3846 We know there are no uncompared elements on the left once we
3847 get u_right < part_left and no uncompared elements on the
3848 right once u_left > part_right. When both these conditions
3849 are met, we have completed the scan of the partition.
3851 Any elements which are between the pivot chunk and the
3852 uncompared elements should be less than the pivot value on
3853 the left side and greater than the pivot value on the right
3854 side (in fact, the goal of the whole algorithm is to arrange
3855 for that to be true and make the groups of less-than and
3856 greater-then elements into new partitions to sort again).
3858 As you marvel at the complexity of the code and wonder why it
3859 has to be so confusing. Consider some of the things this level
3860 of confusion brings:
3862 Once I do a compare, I squeeze every ounce of juice out of it. I
3863 never do compare calls I don't have to do, and I certainly never
3866 I also never swap any elements unless I can prove there is a
3867 good reason. Many sort algorithms will swap a known value with
3868 an uncompared value just to get things in the right place (or
3869 avoid complexity :-), but that uncompared value, once it gets
3870 compared, may then have to be swapped again. A lot of the
3871 complexity of this code is due to the fact that it never swaps
3872 anything except compared values, and it only swaps them when the
3873 compare shows they are out of position.
3875 int pc_left, pc_right;
3876 int u_right, u_left;
3880 pc_left = ((part_left + part_right) / 2);
3882 u_right = pc_left - 1;
3883 u_left = pc_right + 1;
3885 /* Qsort works best when the pivot value is also the median value
3886 in the partition (unfortunately you can't find the median value
3887 without first sorting :-), so to give the algorithm a helping
3888 hand, we pick 3 elements and sort them and use the median value
3889 of that tiny set as the pivot value.
3891 Some versions of qsort like to use the left middle and right as
3892 the 3 elements to sort so they can insure the ends of the
3893 partition will contain values which will stop the scan in the
3894 compare loop, but when you have to call an arbitrarily complex
3895 routine to do a compare, its really better to just keep track of
3896 array index values to know when you hit the edge of the
3897 partition and avoid the extra compare. An even better reason to
3898 avoid using a compare call is the fact that you can drop off the
3899 edge of the array if someone foolishly provides you with an
3900 unstable compare function that doesn't always provide consistent
3903 So, since it is simpler for us to compare the three adjacent
3904 elements in the middle of the partition, those are the ones we
3905 pick here (conveniently pointed at by u_right, pc_left, and
3906 u_left). The values of the left, center, and right elements
3907 are refered to as l c and r in the following comments.
3910 #ifdef QSORT_ORDER_GUESS
3913 s = qsort_cmp(u_right, pc_left);
3916 s = qsort_cmp(pc_left, u_left);
3917 /* if l < c, c < r - already in order - nothing to do */
3919 /* l < c, c == r - already in order, pc grows */
3921 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3923 /* l < c, c > r - need to know more */
3924 s = qsort_cmp(u_right, u_left);
3926 /* l < c, c > r, l < r - swap c & r to get ordered */
3927 qsort_swap(pc_left, u_left);
3928 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3929 } else if (s == 0) {
3930 /* l < c, c > r, l == r - swap c&r, grow pc */
3931 qsort_swap(pc_left, u_left);
3933 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3935 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3936 qsort_rotate(pc_left, u_right, u_left);
3937 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3940 } else if (s == 0) {
3942 s = qsort_cmp(pc_left, u_left);
3944 /* l == c, c < r - already in order, grow pc */
3946 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3947 } else if (s == 0) {
3948 /* l == c, c == r - already in order, grow pc both ways */
3951 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3953 /* l == c, c > r - swap l & r, grow pc */
3954 qsort_swap(u_right, u_left);
3956 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3960 s = qsort_cmp(pc_left, u_left);
3962 /* l > c, c < r - need to know more */
3963 s = qsort_cmp(u_right, u_left);
3965 /* l > c, c < r, l < r - swap l & c to get ordered */
3966 qsort_swap(u_right, pc_left);
3967 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3968 } else if (s == 0) {
3969 /* l > c, c < r, l == r - swap l & c, grow pc */
3970 qsort_swap(u_right, pc_left);
3972 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3974 /* l > c, c < r, l > r - rotate lcr into crl to order */
3975 qsort_rotate(u_right, pc_left, u_left);
3976 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3978 } else if (s == 0) {
3979 /* l > c, c == r - swap ends, grow pc */
3980 qsort_swap(u_right, u_left);
3982 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3984 /* l > c, c > r - swap ends to get in order */
3985 qsort_swap(u_right, u_left);
3986 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3989 /* We now know the 3 middle elements have been compared and
3990 arranged in the desired order, so we can shrink the uncompared
3995 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3997 /* The above massive nested if was the simple part :-). We now have
3998 the middle 3 elements ordered and we need to scan through the
3999 uncompared sets on either side, swapping elements that are on
4000 the wrong side or simply shuffling equal elements around to get
4001 all equal elements into the pivot chunk.
4005 int still_work_on_left;
4006 int still_work_on_right;
4008 /* Scan the uncompared values on the left. If I find a value
4009 equal to the pivot value, move it over so it is adjacent to
4010 the pivot chunk and expand the pivot chunk. If I find a value
4011 less than the pivot value, then just leave it - its already
4012 on the correct side of the partition. If I find a greater
4013 value, then stop the scan.
4015 while ((still_work_on_left = (u_right >= part_left))) {
4016 s = qsort_cmp(u_right, pc_left);
4019 } else if (s == 0) {
4021 if (pc_left != u_right) {
4022 qsort_swap(u_right, pc_left);
4028 qsort_assert(u_right < pc_left);
4029 qsort_assert(pc_left <= pc_right);
4030 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4031 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4034 /* Do a mirror image scan of uncompared values on the right
4036 while ((still_work_on_right = (u_left <= part_right))) {
4037 s = qsort_cmp(pc_right, u_left);
4040 } else if (s == 0) {
4042 if (pc_right != u_left) {
4043 qsort_swap(pc_right, u_left);
4049 qsort_assert(u_left > pc_right);
4050 qsort_assert(pc_left <= pc_right);
4051 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4052 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4055 if (still_work_on_left) {
4056 /* I know I have a value on the left side which needs to be
4057 on the right side, but I need to know more to decide
4058 exactly the best thing to do with it.
4060 if (still_work_on_right) {
4061 /* I know I have values on both side which are out of
4062 position. This is a big win because I kill two birds
4063 with one swap (so to speak). I can advance the
4064 uncompared pointers on both sides after swapping both
4065 of them into the right place.
4067 qsort_swap(u_right, u_left);
4070 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4072 /* I have an out of position value on the left, but the
4073 right is fully scanned, so I "slide" the pivot chunk
4074 and any less-than values left one to make room for the
4075 greater value over on the right. If the out of position
4076 value is immediately adjacent to the pivot chunk (there
4077 are no less-than values), I can do that with a swap,
4078 otherwise, I have to rotate one of the less than values
4079 into the former position of the out of position value
4080 and the right end of the pivot chunk into the left end
4084 if (pc_left == u_right) {
4085 qsort_swap(u_right, pc_right);
4086 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4088 qsort_rotate(u_right, pc_left, pc_right);
4089 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4094 } else if (still_work_on_right) {
4095 /* Mirror image of complex case above: I have an out of
4096 position value on the right, but the left is fully
4097 scanned, so I need to shuffle things around to make room
4098 for the right value on the left.
4101 if (pc_right == u_left) {
4102 qsort_swap(u_left, pc_left);
4103 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4105 qsort_rotate(pc_right, pc_left, u_left);
4106 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4111 /* No more scanning required on either side of partition,
4112 break out of loop and figure out next set of partitions
4118 /* The elements in the pivot chunk are now in the right place. They
4119 will never move or be compared again. All I have to do is decide
4120 what to do with the stuff to the left and right of the pivot
4123 Notes on the QSORT_ORDER_GUESS ifdef code:
4125 1. If I just built these partitions without swapping any (or
4126 very many) elements, there is a chance that the elements are
4127 already ordered properly (being properly ordered will
4128 certainly result in no swapping, but the converse can't be
4131 2. A (properly written) insertion sort will run faster on
4132 already ordered data than qsort will.
4134 3. Perhaps there is some way to make a good guess about
4135 switching to an insertion sort earlier than partition size 6
4136 (for instance - we could save the partition size on the stack
4137 and increase the size each time we find we didn't swap, thus
4138 switching to insertion sort earlier for partitions with a
4139 history of not swapping).
4141 4. Naturally, if I just switch right away, it will make
4142 artificial benchmarks with pure ascending (or descending)
4143 data look really good, but is that a good reason in general?
4147 #ifdef QSORT_ORDER_GUESS
4149 #if QSORT_ORDER_GUESS == 1
4150 qsort_break_even = (part_right - part_left) + 1;
4152 #if QSORT_ORDER_GUESS == 2
4153 qsort_break_even *= 2;
4155 #if QSORT_ORDER_GUESS == 3
4156 int prev_break = qsort_break_even;
4157 qsort_break_even *= qsort_break_even;
4158 if (qsort_break_even < prev_break) {
4159 qsort_break_even = (part_right - part_left) + 1;
4163 qsort_break_even = QSORT_BREAK_EVEN;
4167 if (part_left < pc_left) {
4168 /* There are elements on the left which need more processing.
4169 Check the right as well before deciding what to do.
4171 if (pc_right < part_right) {
4172 /* We have two partitions to be sorted. Stack the biggest one
4173 and process the smallest one on the next iteration. This
4174 minimizes the stack height by insuring that any additional
4175 stack entries must come from the smallest partition which
4176 (because it is smallest) will have the fewest
4177 opportunities to generate additional stack entries.
4179 if ((part_right - pc_right) > (pc_left - part_left)) {
4180 /* stack the right partition, process the left */
4181 partition_stack[next_stack_entry].left = pc_right + 1;
4182 partition_stack[next_stack_entry].right = part_right;
4183 #ifdef QSORT_ORDER_GUESS
4184 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4186 part_right = pc_left - 1;
4188 /* stack the left partition, process the right */
4189 partition_stack[next_stack_entry].left = part_left;
4190 partition_stack[next_stack_entry].right = pc_left - 1;
4191 #ifdef QSORT_ORDER_GUESS
4192 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4194 part_left = pc_right + 1;
4196 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4199 /* The elements on the left are the only remaining elements
4200 that need sorting, arrange for them to be processed as the
4203 part_right = pc_left - 1;
4205 } else if (pc_right < part_right) {
4206 /* There is only one chunk on the right to be sorted, make it
4207 the new partition and loop back around.
4209 part_left = pc_right + 1;
4211 /* This whole partition wound up in the pivot chunk, so
4212 we need to get a new partition off the stack.
4214 if (next_stack_entry == 0) {
4215 /* the stack is empty - we are done */
4219 part_left = partition_stack[next_stack_entry].left;
4220 part_right = partition_stack[next_stack_entry].right;
4221 #ifdef QSORT_ORDER_GUESS
4222 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4226 /* This partition is too small to fool with qsort complexity, just
4227 do an ordinary insertion sort to minimize overhead.
4230 /* Assume 1st element is in right place already, and start checking
4231 at 2nd element to see where it should be inserted.
4233 for (i = part_left + 1; i <= part_right; ++i) {
4235 /* Scan (backwards - just in case 'i' is already in right place)
4236 through the elements already sorted to see if the ith element
4237 belongs ahead of one of them.
4239 for (j = i - 1; j >= part_left; --j) {
4240 if (qsort_cmp(i, j) >= 0) {
4241 /* i belongs right after j
4248 /* Looks like we really need to move some things
4252 for (k = i - 1; k >= j; --k)
4253 array[k + 1] = array[k];
4258 /* That partition is now sorted, grab the next one, or get out
4259 of the loop if there aren't any more.
4262 if (next_stack_entry == 0) {
4263 /* the stack is empty - we are done */
4267 part_left = partition_stack[next_stack_entry].left;
4268 part_right = partition_stack[next_stack_entry].right;
4269 #ifdef QSORT_ORDER_GUESS
4270 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4275 /* Believe it or not, the array is sorted at this point! */
4287 sortcv(pTHXo_ SV *a, SV *b)
4290 I32 oldsaveix = PL_savestack_ix;
4291 I32 oldscopeix = PL_scopestack_ix;
4293 GvSV(PL_firstgv) = a;
4294 GvSV(PL_secondgv) = b;
4295 PL_stack_sp = PL_stack_base;
4298 if (PL_stack_sp != PL_stack_base + 1)
4299 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4300 if (!SvNIOKp(*PL_stack_sp))
4301 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4302 result = SvIV(*PL_stack_sp);
4303 while (PL_scopestack_ix > oldscopeix) {
4306 leave_scope(oldsaveix);
4311 sortcv_stacked(pTHXo_ SV *a, SV *b)
4314 I32 oldsaveix = PL_savestack_ix;
4315 I32 oldscopeix = PL_scopestack_ix;
4320 av = (AV*)PL_curpad[0];
4322 av = GvAV(PL_defgv);
4325 if (AvMAX(av) < 1) {
4326 SV** ary = AvALLOC(av);
4327 if (AvARRAY(av) != ary) {
4328 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4329 SvPVX(av) = (char*)ary;
4331 if (AvMAX(av) < 1) {
4334 SvPVX(av) = (char*)ary;
4341 PL_stack_sp = PL_stack_base;
4344 if (PL_stack_sp != PL_stack_base + 1)
4345 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4346 if (!SvNIOKp(*PL_stack_sp))
4347 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4348 result = SvIV(*PL_stack_sp);
4349 while (PL_scopestack_ix > oldscopeix) {
4352 leave_scope(oldsaveix);
4357 sortcv_xsub(pTHXo_ SV *a, SV *b)
4360 I32 oldsaveix = PL_savestack_ix;
4361 I32 oldscopeix = PL_scopestack_ix;
4363 CV *cv=(CV*)PL_sortcop;
4371 (void)(*CvXSUB(cv))(aTHXo_ cv);
4372 if (PL_stack_sp != PL_stack_base + 1)
4373 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4374 if (!SvNIOKp(*PL_stack_sp))
4375 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4376 result = SvIV(*PL_stack_sp);
4377 while (PL_scopestack_ix > oldscopeix) {
4380 leave_scope(oldsaveix);
4386 sv_ncmp(pTHXo_ SV *a, SV *b)
4390 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4394 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4398 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4400 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4402 if (PL_amagic_generation) { \
4403 if (SvAMAGIC(left)||SvAMAGIC(right))\
4404 *svp = amagic_call(left, \
4412 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4415 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4420 I32 i = SvIVX(tmpsv);
4430 return sv_ncmp(aTHXo_ a, b);
4434 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4437 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4442 I32 i = SvIVX(tmpsv);
4452 return sv_i_ncmp(aTHXo_ a, b);
4456 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4459 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4464 I32 i = SvIVX(tmpsv);
4474 return sv_cmp(str1, str2);
4478 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4481 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4486 I32 i = SvIVX(tmpsv);
4496 return sv_cmp_locale(str1, str2);
4500 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4502 SV *datasv = FILTER_DATA(idx);
4503 int filter_has_file = IoLINES(datasv);
4504 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4505 SV *filter_state = (SV *)IoTOP_GV(datasv);
4506 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4509 /* I was having segfault trouble under Linux 2.2.5 after a
4510 parse error occured. (Had to hack around it with a test
4511 for PL_error_count == 0.) Solaris doesn't segfault --
4512 not sure where the trouble is yet. XXX */
4514 if (filter_has_file) {
4515 len = FILTER_READ(idx+1, buf_sv, maxlen);
4518 if (filter_sub && len >= 0) {
4529 PUSHs(sv_2mortal(newSViv(maxlen)));
4531 PUSHs(filter_state);
4534 count = call_sv(filter_sub, G_SCALAR);
4550 IoLINES(datasv) = 0;
4551 if (filter_child_proc) {
4552 SvREFCNT_dec(filter_child_proc);
4553 IoFMT_GV(datasv) = Nullgv;
4556 SvREFCNT_dec(filter_state);
4557 IoTOP_GV(datasv) = Nullgv;
4560 SvREFCNT_dec(filter_sub);
4561 IoBOTTOM_GV(datasv) = Nullgv;
4563 filter_del(run_user_filter);
4572 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4574 return sv_cmp_locale(str1, str2);
4578 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4580 return sv_cmp(str1, str2);
4583 #endif /* PERL_OBJECT */