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 (!hasargs && !is_xsub) {
887 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
888 SAVESPTR(PL_firstgv);
889 SAVESPTR(PL_secondgv);
890 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
891 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
892 PL_sortstash = stash;
895 sv_lock((SV *)PL_firstgv);
896 sv_lock((SV *)PL_secondgv);
898 SAVESPTR(GvSV(PL_firstgv));
899 SAVESPTR(GvSV(PL_secondgv));
902 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
903 if (!(PL_op->op_flags & OPf_SPECIAL)) {
904 cx->cx_type = CXt_SUB;
905 cx->blk_gimme = G_SCALAR;
908 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
910 PL_sortcxix = cxstack_ix;
912 if (hasargs && !is_xsub) {
913 /* This is mostly copied from pp_entersub */
914 AV *av = (AV*)PL_curpad[0];
917 cx->blk_sub.savearray = GvAV(PL_defgv);
918 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
919 #endif /* USE_THREADS */
920 cx->blk_sub.oldcurpad = PL_curpad;
921 cx->blk_sub.argarray = av;
923 qsortsv((myorigmark+1), max,
924 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
926 POPBLOCK(cx,PL_curpm);
934 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
935 qsortsv(ORIGMARK+1, max,
936 (PL_op->op_private & OPpSORT_NUMERIC)
937 ? ( (PL_op->op_private & OPpSORT_INTEGER)
938 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
939 : ( overloading ? amagic_ncmp : sv_ncmp))
940 : ( (PL_op->op_private & OPpLOCALE)
943 : sv_cmp_locale_static)
944 : ( overloading ? amagic_cmp : sv_cmp_static)));
945 if (PL_op->op_private & OPpSORT_REVERSE) {
947 SV **q = ORIGMARK+max;
957 PL_stack_sp = ORIGMARK + max;
965 if (GIMME == G_ARRAY)
967 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
968 return cLOGOP->op_other;
977 if (GIMME == G_ARRAY) {
978 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
982 SV *targ = PAD_SV(PL_op->op_targ);
984 if ((PL_op->op_private & OPpFLIP_LINENUM)
985 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
987 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
988 if (PL_op->op_flags & OPf_SPECIAL) {
996 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1009 if (GIMME == G_ARRAY) {
1015 if (SvGMAGICAL(left))
1017 if (SvGMAGICAL(right))
1020 if (SvNIOKp(left) || !SvPOKp(left) ||
1021 SvNIOKp(right) || !SvPOKp(right) ||
1022 (looks_like_number(left) && *SvPVX(left) != '0' &&
1023 looks_like_number(right) && *SvPVX(right) != '0'))
1025 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1026 DIE(aTHX_ "Range iterator outside integer range");
1037 sv = sv_2mortal(newSViv(i++));
1042 SV *final = sv_mortalcopy(right);
1044 char *tmps = SvPV(final, len);
1046 sv = sv_mortalcopy(left);
1048 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1050 if (strEQ(SvPVX(sv),tmps))
1052 sv = sv_2mortal(newSVsv(sv));
1059 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1061 if ((PL_op->op_private & OPpFLIP_LINENUM)
1062 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1064 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1065 sv_catpv(targ, "E0");
1076 S_dopoptolabel(pTHX_ char *label)
1080 register PERL_CONTEXT *cx;
1082 for (i = cxstack_ix; i >= 0; i--) {
1084 switch (CxTYPE(cx)) {
1086 if (ckWARN(WARN_EXITING))
1087 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1088 PL_op_name[PL_op->op_type]);
1091 if (ckWARN(WARN_EXITING))
1092 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1093 PL_op_name[PL_op->op_type]);
1096 if (ckWARN(WARN_EXITING))
1097 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1098 PL_op_name[PL_op->op_type]);
1101 if (ckWARN(WARN_EXITING))
1102 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1103 PL_op_name[PL_op->op_type]);
1106 if (ckWARN(WARN_EXITING))
1107 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1108 PL_op_name[PL_op->op_type]);
1111 if (!cx->blk_loop.label ||
1112 strNE(label, cx->blk_loop.label) ) {
1113 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1114 (long)i, cx->blk_loop.label));
1117 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1125 Perl_dowantarray(pTHX)
1127 I32 gimme = block_gimme();
1128 return (gimme == G_VOID) ? G_SCALAR : gimme;
1132 Perl_block_gimme(pTHX)
1137 cxix = dopoptosub(cxstack_ix);
1141 switch (cxstack[cxix].blk_gimme) {
1149 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1156 S_dopoptosub(pTHX_ I32 startingblock)
1159 return dopoptosub_at(cxstack, startingblock);
1163 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1167 register PERL_CONTEXT *cx;
1168 for (i = startingblock; i >= 0; i--) {
1170 switch (CxTYPE(cx)) {
1176 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1184 S_dopoptoeval(pTHX_ I32 startingblock)
1188 register PERL_CONTEXT *cx;
1189 for (i = startingblock; i >= 0; i--) {
1191 switch (CxTYPE(cx)) {
1195 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1203 S_dopoptoloop(pTHX_ I32 startingblock)
1207 register PERL_CONTEXT *cx;
1208 for (i = startingblock; i >= 0; i--) {
1210 switch (CxTYPE(cx)) {
1212 if (ckWARN(WARN_EXITING))
1213 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1214 PL_op_name[PL_op->op_type]);
1217 if (ckWARN(WARN_EXITING))
1218 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1219 PL_op_name[PL_op->op_type]);
1222 if (ckWARN(WARN_EXITING))
1223 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1224 PL_op_name[PL_op->op_type]);
1227 if (ckWARN(WARN_EXITING))
1228 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1229 PL_op_name[PL_op->op_type]);
1232 if (ckWARN(WARN_EXITING))
1233 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1234 PL_op_name[PL_op->op_type]);
1237 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1245 Perl_dounwind(pTHX_ I32 cxix)
1248 register PERL_CONTEXT *cx;
1251 while (cxstack_ix > cxix) {
1253 cx = &cxstack[cxstack_ix];
1254 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1255 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1256 /* Note: we don't need to restore the base context info till the end. */
1257 switch (CxTYPE(cx)) {
1260 continue; /* not break */
1282 * Closures mentioned at top level of eval cannot be referenced
1283 * again, and their presence indirectly causes a memory leak.
1284 * (Note that the fact that compcv and friends are still set here
1285 * is, AFAIK, an accident.) --Chip
1287 * XXX need to get comppad et al from eval's cv rather than
1288 * relying on the incidental global values.
1291 S_free_closures(pTHX)
1294 SV **svp = AvARRAY(PL_comppad_name);
1296 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1298 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1300 svp[ix] = &PL_sv_undef;
1304 SvREFCNT_dec(CvOUTSIDE(sv));
1305 CvOUTSIDE(sv) = Nullcv;
1318 Perl_qerror(pTHX_ SV *err)
1321 sv_catsv(ERRSV, err);
1323 sv_catsv(PL_errors, err);
1325 Perl_warn(aTHX_ "%"SVf, err);
1330 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1335 register PERL_CONTEXT *cx;
1340 if (PL_in_eval & EVAL_KEEPERR) {
1341 static char prefix[] = "\t(in cleanup) ";
1346 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1349 if (*e != *message || strNE(e,message))
1353 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1354 sv_catpvn(err, prefix, sizeof(prefix)-1);
1355 sv_catpvn(err, message, msglen);
1356 if (ckWARN(WARN_MISC)) {
1357 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1358 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1363 sv_setpvn(ERRSV, message, msglen);
1366 message = SvPVx(ERRSV, msglen);
1368 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1369 && PL_curstackinfo->si_prev)
1378 if (cxix < cxstack_ix)
1381 POPBLOCK(cx,PL_curpm);
1382 if (CxTYPE(cx) != CXt_EVAL) {
1383 PerlIO_write(Perl_error_log, "panic: die ", 11);
1384 PerlIO_write(Perl_error_log, message, msglen);
1389 if (gimme == G_SCALAR)
1390 *++newsp = &PL_sv_undef;
1391 PL_stack_sp = newsp;
1395 if (optype == OP_REQUIRE) {
1396 char* msg = SvPVx(ERRSV, n_a);
1397 DIE(aTHX_ "%sCompilation failed in require",
1398 *msg ? msg : "Unknown error\n");
1400 return pop_return();
1404 message = SvPVx(ERRSV, msglen);
1407 /* SFIO can really mess with your errno */
1410 PerlIO *serr = Perl_error_log;
1412 PerlIO_write(serr, message, msglen);
1413 (void)PerlIO_flush(serr);
1426 if (SvTRUE(left) != SvTRUE(right))
1438 RETURNOP(cLOGOP->op_other);
1447 RETURNOP(cLOGOP->op_other);
1453 register I32 cxix = dopoptosub(cxstack_ix);
1454 register PERL_CONTEXT *cx;
1455 register PERL_CONTEXT *ccstack = cxstack;
1456 PERL_SI *top_si = PL_curstackinfo;
1467 /* we may be in a higher stacklevel, so dig down deeper */
1468 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1469 top_si = top_si->si_prev;
1470 ccstack = top_si->si_cxstack;
1471 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1474 if (GIMME != G_ARRAY)
1478 if (PL_DBsub && cxix >= 0 &&
1479 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1483 cxix = dopoptosub_at(ccstack, cxix - 1);
1486 cx = &ccstack[cxix];
1487 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1488 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1489 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1490 field below is defined for any cx. */
1491 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1492 cx = &ccstack[dbcxix];
1495 stashname = CopSTASHPV(cx->blk_oldcop);
1496 if (GIMME != G_ARRAY) {
1498 PUSHs(&PL_sv_undef);
1501 sv_setpv(TARG, stashname);
1508 PUSHs(&PL_sv_undef);
1510 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1511 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1512 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1515 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1516 /* So is ccstack[dbcxix]. */
1518 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1519 PUSHs(sv_2mortal(sv));
1520 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1523 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1524 PUSHs(sv_2mortal(newSViv(0)));
1526 gimme = (I32)cx->blk_gimme;
1527 if (gimme == G_VOID)
1528 PUSHs(&PL_sv_undef);
1530 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1531 if (CxTYPE(cx) == CXt_EVAL) {
1533 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1534 PUSHs(cx->blk_eval.cur_text);
1538 else if (cx->blk_eval.old_namesv) {
1539 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1542 /* eval BLOCK (try blocks have old_namesv == 0) */
1544 PUSHs(&PL_sv_undef);
1545 PUSHs(&PL_sv_undef);
1549 PUSHs(&PL_sv_undef);
1550 PUSHs(&PL_sv_undef);
1552 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1553 && CopSTASH_eq(PL_curcop, PL_debstash))
1555 AV *ary = cx->blk_sub.argarray;
1556 int off = AvARRAY(ary) - AvALLOC(ary);
1560 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1563 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1566 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1567 av_extend(PL_dbargs, AvFILLp(ary) + off);
1568 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1569 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1571 /* XXX only hints propagated via op_private are currently
1572 * visible (others are not easily accessible, since they
1573 * use the global PL_hints) */
1574 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1575 HINT_PRIVATE_MASK)));
1578 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1580 if (old_warnings == pWARN_NONE ||
1581 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1582 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1583 else if (old_warnings == pWARN_ALL ||
1584 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1585 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1587 mask = newSVsv(old_warnings);
1588 PUSHs(sv_2mortal(mask));
1603 sv_reset(tmps, CopSTASH(PL_curcop));
1615 PL_curcop = (COP*)PL_op;
1616 TAINT_NOT; /* Each statement is presumed innocent */
1617 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1620 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1624 register PERL_CONTEXT *cx;
1625 I32 gimme = G_ARRAY;
1632 DIE(aTHX_ "No DB::DB routine defined");
1634 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1646 push_return(PL_op->op_next);
1647 PUSHBLOCK(cx, CXt_SUB, SP);
1650 (void)SvREFCNT_inc(cv);
1651 SAVEVPTR(PL_curpad);
1652 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1653 RETURNOP(CvSTART(cv));
1667 register PERL_CONTEXT *cx;
1668 I32 gimme = GIMME_V;
1670 U32 cxtype = CXt_LOOP;
1679 if (PL_op->op_flags & OPf_SPECIAL) {
1681 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1682 SAVEGENERICSV(*svp);
1686 #endif /* USE_THREADS */
1687 if (PL_op->op_targ) {
1688 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1691 iterdata = (void*)PL_op->op_targ;
1692 cxtype |= CXp_PADVAR;
1697 svp = &GvSV(gv); /* symbol table variable */
1698 SAVEGENERICSV(*svp);
1701 iterdata = (void*)gv;
1707 PUSHBLOCK(cx, cxtype, SP);
1709 PUSHLOOP(cx, iterdata, MARK);
1711 PUSHLOOP(cx, svp, MARK);
1713 if (PL_op->op_flags & OPf_STACKED) {
1714 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1715 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1717 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1718 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1719 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1720 looks_like_number((SV*)cx->blk_loop.iterary) &&
1721 *SvPVX(cx->blk_loop.iterary) != '0'))
1723 if (SvNV(sv) < IV_MIN ||
1724 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1725 DIE(aTHX_ "Range iterator outside integer range");
1726 cx->blk_loop.iterix = SvIV(sv);
1727 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1730 cx->blk_loop.iterlval = newSVsv(sv);
1734 cx->blk_loop.iterary = PL_curstack;
1735 AvFILLp(PL_curstack) = SP - PL_stack_base;
1736 cx->blk_loop.iterix = MARK - PL_stack_base;
1745 register PERL_CONTEXT *cx;
1746 I32 gimme = GIMME_V;
1752 PUSHBLOCK(cx, CXt_LOOP, SP);
1753 PUSHLOOP(cx, 0, SP);
1761 register PERL_CONTEXT *cx;
1769 newsp = PL_stack_base + cx->blk_loop.resetsp;
1772 if (gimme == G_VOID)
1774 else if (gimme == G_SCALAR) {
1776 *++newsp = sv_mortalcopy(*SP);
1778 *++newsp = &PL_sv_undef;
1782 *++newsp = sv_mortalcopy(*++mark);
1783 TAINT_NOT; /* Each item is independent */
1789 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1790 PL_curpm = newpm; /* ... and pop $1 et al */
1802 register PERL_CONTEXT *cx;
1803 bool popsub2 = FALSE;
1804 bool clear_errsv = FALSE;
1811 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1812 if (cxstack_ix == PL_sortcxix
1813 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1815 if (cxstack_ix > PL_sortcxix)
1816 dounwind(PL_sortcxix);
1817 AvARRAY(PL_curstack)[1] = *SP;
1818 PL_stack_sp = PL_stack_base + 1;
1823 cxix = dopoptosub(cxstack_ix);
1825 DIE(aTHX_ "Can't return outside a subroutine");
1826 if (cxix < cxstack_ix)
1830 switch (CxTYPE(cx)) {
1835 if (!(PL_in_eval & EVAL_KEEPERR))
1840 if (AvFILLp(PL_comppad_name) >= 0)
1843 if (optype == OP_REQUIRE &&
1844 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1846 /* Unassume the success we assumed earlier. */
1847 SV *nsv = cx->blk_eval.old_namesv;
1848 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1849 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1856 DIE(aTHX_ "panic: return");
1860 if (gimme == G_SCALAR) {
1863 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1865 *++newsp = SvREFCNT_inc(*SP);
1870 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1872 *++newsp = sv_mortalcopy(sv);
1877 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1880 *++newsp = sv_mortalcopy(*SP);
1883 *++newsp = &PL_sv_undef;
1885 else if (gimme == G_ARRAY) {
1886 while (++MARK <= SP) {
1887 *++newsp = (popsub2 && SvTEMP(*MARK))
1888 ? *MARK : sv_mortalcopy(*MARK);
1889 TAINT_NOT; /* Each item is independent */
1892 PL_stack_sp = newsp;
1894 /* Stack values are safe: */
1896 POPSUB(cx,sv); /* release CV and @_ ... */
1900 PL_curpm = newpm; /* ... and pop $1 et al */
1906 return pop_return();
1913 register PERL_CONTEXT *cx;
1923 if (PL_op->op_flags & OPf_SPECIAL) {
1924 cxix = dopoptoloop(cxstack_ix);
1926 DIE(aTHX_ "Can't \"last\" outside a loop block");
1929 cxix = dopoptolabel(cPVOP->op_pv);
1931 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1933 if (cxix < cxstack_ix)
1938 switch (CxTYPE(cx)) {
1941 newsp = PL_stack_base + cx->blk_loop.resetsp;
1942 nextop = cx->blk_loop.last_op->op_next;
1946 nextop = pop_return();
1950 nextop = pop_return();
1954 nextop = pop_return();
1957 DIE(aTHX_ "panic: last");
1961 if (gimme == G_SCALAR) {
1963 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1964 ? *SP : sv_mortalcopy(*SP);
1966 *++newsp = &PL_sv_undef;
1968 else if (gimme == G_ARRAY) {
1969 while (++MARK <= SP) {
1970 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1971 ? *MARK : sv_mortalcopy(*MARK);
1972 TAINT_NOT; /* Each item is independent */
1978 /* Stack values are safe: */
1981 POPLOOP(cx); /* release loop vars ... */
1985 POPSUB(cx,sv); /* release CV and @_ ... */
1988 PL_curpm = newpm; /* ... and pop $1 et al */
1998 register PERL_CONTEXT *cx;
2001 if (PL_op->op_flags & OPf_SPECIAL) {
2002 cxix = dopoptoloop(cxstack_ix);
2004 DIE(aTHX_ "Can't \"next\" outside a loop block");
2007 cxix = dopoptolabel(cPVOP->op_pv);
2009 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2011 if (cxix < cxstack_ix)
2014 /* clear off anything above the scope we're re-entering, but
2015 * save the rest until after a possible continue block */
2016 inner = PL_scopestack_ix;
2018 if (PL_scopestack_ix < inner)
2019 leave_scope(PL_scopestack[PL_scopestack_ix]);
2020 return cx->blk_loop.next_op;
2026 register PERL_CONTEXT *cx;
2029 if (PL_op->op_flags & OPf_SPECIAL) {
2030 cxix = dopoptoloop(cxstack_ix);
2032 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2035 cxix = dopoptolabel(cPVOP->op_pv);
2037 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2039 if (cxix < cxstack_ix)
2043 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2044 LEAVE_SCOPE(oldsave);
2045 return cx->blk_loop.redo_op;
2049 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2053 static char too_deep[] = "Target of goto is too deeply nested";
2056 Perl_croak(aTHX_ too_deep);
2057 if (o->op_type == OP_LEAVE ||
2058 o->op_type == OP_SCOPE ||
2059 o->op_type == OP_LEAVELOOP ||
2060 o->op_type == OP_LEAVETRY)
2062 *ops++ = cUNOPo->op_first;
2064 Perl_croak(aTHX_ too_deep);
2067 if (o->op_flags & OPf_KIDS) {
2069 /* First try all the kids at this level, since that's likeliest. */
2070 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2071 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2072 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2075 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2076 if (kid == PL_lastgotoprobe)
2078 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2080 (ops[-1]->op_type != OP_NEXTSTATE &&
2081 ops[-1]->op_type != OP_DBSTATE)))
2083 if ((o = dofindlabel(kid, label, ops, oplimit)))
2102 register PERL_CONTEXT *cx;
2103 #define GOTO_DEPTH 64
2104 OP *enterops[GOTO_DEPTH];
2106 int do_dump = (PL_op->op_type == OP_DUMP);
2107 static char must_have_label[] = "goto must have label";
2110 if (PL_op->op_flags & OPf_STACKED) {
2114 /* This egregious kludge implements goto &subroutine */
2115 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2117 register PERL_CONTEXT *cx;
2118 CV* cv = (CV*)SvRV(sv);
2124 if (!CvROOT(cv) && !CvXSUB(cv)) {
2129 /* autoloaded stub? */
2130 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2132 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2133 GvNAMELEN(gv), FALSE);
2134 if (autogv && (cv = GvCV(autogv)))
2136 tmpstr = sv_newmortal();
2137 gv_efullname3(tmpstr, gv, Nullch);
2138 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2140 DIE(aTHX_ "Goto undefined subroutine");
2143 /* First do some returnish stuff. */
2144 cxix = dopoptosub(cxstack_ix);
2146 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2147 if (cxix < cxstack_ix)
2150 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2151 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2153 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2154 /* put @_ back onto stack */
2155 AV* av = cx->blk_sub.argarray;
2157 items = AvFILLp(av) + 1;
2159 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2160 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2161 PL_stack_sp += items;
2163 SvREFCNT_dec(GvAV(PL_defgv));
2164 GvAV(PL_defgv) = cx->blk_sub.savearray;
2165 #endif /* USE_THREADS */
2166 /* abandon @_ if it got reified */
2168 (void)sv_2mortal((SV*)av); /* delay until return */
2170 av_extend(av, items-1);
2171 AvFLAGS(av) = AVf_REIFY;
2172 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2175 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2178 av = (AV*)PL_curpad[0];
2180 av = GvAV(PL_defgv);
2182 items = AvFILLp(av) + 1;
2184 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2185 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2186 PL_stack_sp += items;
2188 if (CxTYPE(cx) == CXt_SUB &&
2189 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2190 SvREFCNT_dec(cx->blk_sub.cv);
2191 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2192 LEAVE_SCOPE(oldsave);
2194 /* Now do some callish stuff. */
2197 #ifdef PERL_XSUB_OLDSTYLE
2198 if (CvOLDSTYLE(cv)) {
2199 I32 (*fp3)(int,int,int);
2204 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2205 items = (*fp3)(CvXSUBANY(cv).any_i32,
2206 mark - PL_stack_base + 1,
2208 SP = PL_stack_base + items;
2211 #endif /* PERL_XSUB_OLDSTYLE */
2216 PL_stack_sp--; /* There is no cv arg. */
2217 /* Push a mark for the start of arglist */
2219 (void)(*CvXSUB(cv))(aTHXo_ cv);
2220 /* Pop the current context like a decent sub should */
2221 POPBLOCK(cx, PL_curpm);
2222 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2225 return pop_return();
2228 AV* padlist = CvPADLIST(cv);
2229 SV** svp = AvARRAY(padlist);
2230 if (CxTYPE(cx) == CXt_EVAL) {
2231 PL_in_eval = cx->blk_eval.old_in_eval;
2232 PL_eval_root = cx->blk_eval.old_eval_root;
2233 cx->cx_type = CXt_SUB;
2234 cx->blk_sub.hasargs = 0;
2236 cx->blk_sub.cv = cv;
2237 cx->blk_sub.olddepth = CvDEPTH(cv);
2239 if (CvDEPTH(cv) < 2)
2240 (void)SvREFCNT_inc(cv);
2241 else { /* save temporaries on recursion? */
2242 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2243 sub_crush_depth(cv);
2244 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2245 AV *newpad = newAV();
2246 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2247 I32 ix = AvFILLp((AV*)svp[1]);
2248 I32 names_fill = AvFILLp((AV*)svp[0]);
2249 svp = AvARRAY(svp[0]);
2250 for ( ;ix > 0; ix--) {
2251 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2252 char *name = SvPVX(svp[ix]);
2253 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2256 /* outer lexical or anon code */
2257 av_store(newpad, ix,
2258 SvREFCNT_inc(oldpad[ix]) );
2260 else { /* our own lexical */
2262 av_store(newpad, ix, sv = (SV*)newAV());
2263 else if (*name == '%')
2264 av_store(newpad, ix, sv = (SV*)newHV());
2266 av_store(newpad, ix, sv = NEWSV(0,0));
2270 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2271 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2274 av_store(newpad, ix, sv = NEWSV(0,0));
2278 if (cx->blk_sub.hasargs) {
2281 av_store(newpad, 0, (SV*)av);
2282 AvFLAGS(av) = AVf_REIFY;
2284 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2285 AvFILLp(padlist) = CvDEPTH(cv);
2286 svp = AvARRAY(padlist);
2290 if (!cx->blk_sub.hasargs) {
2291 AV* av = (AV*)PL_curpad[0];
2293 items = AvFILLp(av) + 1;
2295 /* Mark is at the end of the stack. */
2297 Copy(AvARRAY(av), SP + 1, items, SV*);
2302 #endif /* USE_THREADS */
2303 SAVEVPTR(PL_curpad);
2304 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2306 if (cx->blk_sub.hasargs)
2307 #endif /* USE_THREADS */
2309 AV* av = (AV*)PL_curpad[0];
2313 cx->blk_sub.savearray = GvAV(PL_defgv);
2314 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2315 #endif /* USE_THREADS */
2316 cx->blk_sub.oldcurpad = PL_curpad;
2317 cx->blk_sub.argarray = av;
2320 if (items >= AvMAX(av) + 1) {
2322 if (AvARRAY(av) != ary) {
2323 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2324 SvPVX(av) = (char*)ary;
2326 if (items >= AvMAX(av) + 1) {
2327 AvMAX(av) = items - 1;
2328 Renew(ary,items+1,SV*);
2330 SvPVX(av) = (char*)ary;
2333 Copy(mark,AvARRAY(av),items,SV*);
2334 AvFILLp(av) = items - 1;
2335 assert(!AvREAL(av));
2342 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2344 * We do not care about using sv to call CV;
2345 * it's for informational purposes only.
2347 SV *sv = GvSV(PL_DBsub);
2350 if (PERLDB_SUB_NN) {
2351 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2354 gv_efullname3(sv, CvGV(cv), Nullch);
2357 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2358 PUSHMARK( PL_stack_sp );
2359 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2363 RETURNOP(CvSTART(cv));
2367 label = SvPV(sv,n_a);
2368 if (!(do_dump || *label))
2369 DIE(aTHX_ must_have_label);
2372 else if (PL_op->op_flags & OPf_SPECIAL) {
2374 DIE(aTHX_ must_have_label);
2377 label = cPVOP->op_pv;
2379 if (label && *label) {
2384 PL_lastgotoprobe = 0;
2386 for (ix = cxstack_ix; ix >= 0; ix--) {
2388 switch (CxTYPE(cx)) {
2390 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2393 gotoprobe = cx->blk_oldcop->op_sibling;
2399 gotoprobe = cx->blk_oldcop->op_sibling;
2401 gotoprobe = PL_main_root;
2404 if (CvDEPTH(cx->blk_sub.cv)) {
2405 gotoprobe = CvROOT(cx->blk_sub.cv);
2411 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2414 DIE(aTHX_ "panic: goto");
2415 gotoprobe = PL_main_root;
2419 retop = dofindlabel(gotoprobe, label,
2420 enterops, enterops + GOTO_DEPTH);
2424 PL_lastgotoprobe = gotoprobe;
2427 DIE(aTHX_ "Can't find label %s", label);
2429 /* pop unwanted frames */
2431 if (ix < cxstack_ix) {
2438 oldsave = PL_scopestack[PL_scopestack_ix];
2439 LEAVE_SCOPE(oldsave);
2442 /* push wanted frames */
2444 if (*enterops && enterops[1]) {
2446 for (ix = 1; enterops[ix]; ix++) {
2447 PL_op = enterops[ix];
2448 /* Eventually we may want to stack the needed arguments
2449 * for each op. For now, we punt on the hard ones. */
2450 if (PL_op->op_type == OP_ENTERITER)
2451 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2452 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2460 if (!retop) retop = PL_main_start;
2462 PL_restartop = retop;
2463 PL_do_undump = TRUE;
2467 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2468 PL_do_undump = FALSE;
2484 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2488 PL_exit_flags |= PERL_EXIT_EXPECTED;
2490 PUSHs(&PL_sv_undef);
2498 NV value = SvNVx(GvSV(cCOP->cop_gv));
2499 register I32 match = I_32(value);
2502 if (((NV)match) > value)
2503 --match; /* was fractional--truncate other way */
2505 match -= cCOP->uop.scop.scop_offset;
2508 else if (match > cCOP->uop.scop.scop_max)
2509 match = cCOP->uop.scop.scop_max;
2510 PL_op = cCOP->uop.scop.scop_next[match];
2520 PL_op = PL_op->op_next; /* can't assume anything */
2523 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2524 match -= cCOP->uop.scop.scop_offset;
2527 else if (match > cCOP->uop.scop.scop_max)
2528 match = cCOP->uop.scop.scop_max;
2529 PL_op = cCOP->uop.scop.scop_next[match];
2538 S_save_lines(pTHX_ AV *array, SV *sv)
2540 register char *s = SvPVX(sv);
2541 register char *send = SvPVX(sv) + SvCUR(sv);
2543 register I32 line = 1;
2545 while (s && s < send) {
2546 SV *tmpstr = NEWSV(85,0);
2548 sv_upgrade(tmpstr, SVt_PVMG);
2549 t = strchr(s, '\n');
2555 sv_setpvn(tmpstr, s, t - s);
2556 av_store(array, line++, tmpstr);
2561 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2563 S_docatch_body(pTHX_ va_list args)
2565 return docatch_body();
2570 S_docatch_body(pTHX)
2577 S_docatch(pTHX_ OP *o)
2582 volatile PERL_SI *cursi = PL_curstackinfo;
2586 assert(CATCH_GET == TRUE);
2589 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2591 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2597 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2603 if (PL_restartop && cursi == PL_curstackinfo) {
2604 PL_op = PL_restartop;
2621 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2622 /* sv Text to convert to OP tree. */
2623 /* startop op_free() this to undo. */
2624 /* code Short string id of the caller. */
2626 dSP; /* Make POPBLOCK work. */
2629 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2633 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2634 char *tmpbuf = tbuf;
2640 /* switch to eval mode */
2642 if (PL_curcop == &PL_compiling) {
2643 SAVECOPSTASH_FREE(&PL_compiling);
2644 CopSTASH_set(&PL_compiling, PL_curstash);
2646 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2647 SV *sv = sv_newmortal();
2648 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2649 code, (unsigned long)++PL_evalseq,
2650 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2654 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2655 SAVECOPFILE_FREE(&PL_compiling);
2656 CopFILE_set(&PL_compiling, tmpbuf+2);
2657 SAVECOPLINE(&PL_compiling);
2658 CopLINE_set(&PL_compiling, 1);
2659 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2660 deleting the eval's FILEGV from the stash before gv_check() runs
2661 (i.e. before run-time proper). To work around the coredump that
2662 ensues, we always turn GvMULTI_on for any globals that were
2663 introduced within evals. See force_ident(). GSAR 96-10-12 */
2664 safestr = savepv(tmpbuf);
2665 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2667 #ifdef OP_IN_REGISTER
2675 PL_op->op_type = OP_ENTEREVAL;
2676 PL_op->op_flags = 0; /* Avoid uninit warning. */
2677 PUSHBLOCK(cx, CXt_EVAL, SP);
2678 PUSHEVAL(cx, 0, Nullgv);
2679 rop = doeval(G_SCALAR, startop);
2680 POPBLOCK(cx,PL_curpm);
2683 (*startop)->op_type = OP_NULL;
2684 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2686 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2688 if (PL_curcop == &PL_compiling)
2689 PL_compiling.op_private = PL_hints;
2690 #ifdef OP_IN_REGISTER
2696 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2698 S_doeval(pTHX_ int gimme, OP** startop)
2706 PL_in_eval = EVAL_INEVAL;
2710 /* set up a scratch pad */
2713 SAVEVPTR(PL_curpad);
2714 SAVESPTR(PL_comppad);
2715 SAVESPTR(PL_comppad_name);
2716 SAVEI32(PL_comppad_name_fill);
2717 SAVEI32(PL_min_intro_pending);
2718 SAVEI32(PL_max_intro_pending);
2721 for (i = cxstack_ix - 1; i >= 0; i--) {
2722 PERL_CONTEXT *cx = &cxstack[i];
2723 if (CxTYPE(cx) == CXt_EVAL)
2725 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2726 caller = cx->blk_sub.cv;
2731 SAVESPTR(PL_compcv);
2732 PL_compcv = (CV*)NEWSV(1104,0);
2733 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2734 CvEVAL_on(PL_compcv);
2736 CvOWNER(PL_compcv) = 0;
2737 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2738 MUTEX_INIT(CvMUTEXP(PL_compcv));
2739 #endif /* USE_THREADS */
2741 PL_comppad = newAV();
2742 av_push(PL_comppad, Nullsv);
2743 PL_curpad = AvARRAY(PL_comppad);
2744 PL_comppad_name = newAV();
2745 PL_comppad_name_fill = 0;
2746 PL_min_intro_pending = 0;
2749 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2750 PL_curpad[0] = (SV*)newAV();
2751 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2752 #endif /* USE_THREADS */
2754 comppadlist = newAV();
2755 AvREAL_off(comppadlist);
2756 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2757 av_store(comppadlist, 1, (SV*)PL_comppad);
2758 CvPADLIST(PL_compcv) = comppadlist;
2761 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2763 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2766 SAVEFREESV(PL_compcv);
2768 /* make sure we compile in the right package */
2770 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2771 SAVESPTR(PL_curstash);
2772 PL_curstash = CopSTASH(PL_curcop);
2774 SAVESPTR(PL_beginav);
2775 PL_beginav = newAV();
2776 SAVEFREESV(PL_beginav);
2777 SAVEI32(PL_error_count);
2779 /* try to compile it */
2781 PL_eval_root = Nullop;
2783 PL_curcop = &PL_compiling;
2784 PL_curcop->cop_arybase = 0;
2785 SvREFCNT_dec(PL_rs);
2786 PL_rs = newSVpvn("\n", 1);
2787 if (saveop && saveop->op_flags & OPf_SPECIAL)
2788 PL_in_eval |= EVAL_KEEPERR;
2791 if (yyparse() || PL_error_count || !PL_eval_root) {
2795 I32 optype = 0; /* Might be reset by POPEVAL. */
2800 op_free(PL_eval_root);
2801 PL_eval_root = Nullop;
2803 SP = PL_stack_base + POPMARK; /* pop original mark */
2805 POPBLOCK(cx,PL_curpm);
2811 if (optype == OP_REQUIRE) {
2812 char* msg = SvPVx(ERRSV, n_a);
2813 DIE(aTHX_ "%sCompilation failed in require",
2814 *msg ? msg : "Unknown error\n");
2817 char* msg = SvPVx(ERRSV, n_a);
2819 POPBLOCK(cx,PL_curpm);
2821 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2822 (*msg ? msg : "Unknown error\n"));
2824 SvREFCNT_dec(PL_rs);
2825 PL_rs = SvREFCNT_inc(PL_nrs);
2827 MUTEX_LOCK(&PL_eval_mutex);
2829 COND_SIGNAL(&PL_eval_cond);
2830 MUTEX_UNLOCK(&PL_eval_mutex);
2831 #endif /* USE_THREADS */
2834 SvREFCNT_dec(PL_rs);
2835 PL_rs = SvREFCNT_inc(PL_nrs);
2836 CopLINE_set(&PL_compiling, 0);
2838 *startop = PL_eval_root;
2839 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2840 CvOUTSIDE(PL_compcv) = Nullcv;
2842 SAVEFREEOP(PL_eval_root);
2844 scalarvoid(PL_eval_root);
2845 else if (gimme & G_ARRAY)
2848 scalar(PL_eval_root);
2850 DEBUG_x(dump_eval());
2852 /* Register with debugger: */
2853 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2854 CV *cv = get_cv("DB::postponed", FALSE);
2858 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2860 call_sv((SV*)cv, G_DISCARD);
2864 /* compiled okay, so do it */
2866 CvDEPTH(PL_compcv) = 1;
2867 SP = PL_stack_base + POPMARK; /* pop original mark */
2868 PL_op = saveop; /* The caller may need it. */
2870 MUTEX_LOCK(&PL_eval_mutex);
2872 COND_SIGNAL(&PL_eval_cond);
2873 MUTEX_UNLOCK(&PL_eval_mutex);
2874 #endif /* USE_THREADS */
2876 RETURNOP(PL_eval_start);
2880 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2882 STRLEN namelen = strlen(name);
2885 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2886 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2887 char *pmc = SvPV_nolen(pmcsv);
2890 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2891 fp = PerlIO_open(name, mode);
2894 if (PerlLIO_stat(name, &pmstat) < 0 ||
2895 pmstat.st_mtime < pmcstat.st_mtime)
2897 fp = PerlIO_open(pmc, mode);
2900 fp = PerlIO_open(name, mode);
2903 SvREFCNT_dec(pmcsv);
2906 fp = PerlIO_open(name, mode);
2914 register PERL_CONTEXT *cx;
2919 SV *namesv = Nullsv;
2921 I32 gimme = G_SCALAR;
2922 PerlIO *tryrsfp = 0;
2924 int filter_has_file = 0;
2925 GV *filter_child_proc = 0;
2926 SV *filter_state = 0;
2931 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2932 UV rev = 0, ver = 0, sver = 0;
2934 U8 *s = (U8*)SvPVX(sv);
2935 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2937 rev = utf8_to_uv(s, &len);
2940 ver = utf8_to_uv(s, &len);
2943 sver = utf8_to_uv(s, &len);
2946 if (PERL_REVISION < rev
2947 || (PERL_REVISION == rev
2948 && (PERL_VERSION < ver
2949 || (PERL_VERSION == ver
2950 && PERL_SUBVERSION < sver))))
2952 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2953 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2954 PERL_VERSION, PERL_SUBVERSION);
2958 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2959 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2960 + ((NV)PERL_SUBVERSION/(NV)1000000)
2961 + 0.00000099 < SvNV(sv))
2965 NV nver = (nrev - rev) * 1000;
2966 UV ver = (UV)(nver + 0.0009);
2967 NV nsver = (nver - ver) * 1000;
2968 UV sver = (UV)(nsver + 0.0009);
2970 /* help out with the "use 5.6" confusion */
2971 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2972 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2973 "this is only v%d.%d.%d, stopped"
2974 " (did you mean v%"UVuf".%"UVuf".0?)",
2975 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2976 PERL_SUBVERSION, rev, ver/100);
2979 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2980 "this is only v%d.%d.%d, stopped",
2981 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2988 name = SvPV(sv, len);
2989 if (!(name && len > 0 && *name))
2990 DIE(aTHX_ "Null filename used");
2991 TAINT_PROPER("require");
2992 if (PL_op->op_type == OP_REQUIRE &&
2993 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2994 *svp != &PL_sv_undef)
2997 /* prepare to compile file */
2999 if (PERL_FILE_IS_ABSOLUTE(name)
3000 || (*name == '.' && (name[1] == '/' ||
3001 (name[1] == '.' && name[2] == '/'))))
3004 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3005 #ifdef MACOS_TRADITIONAL
3006 /* We consider paths of the form :a:b ambiguous and interpret them first
3007 as global then as local
3009 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3018 AV *ar = GvAVn(PL_incgv);
3022 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3025 namesv = NEWSV(806, 0);
3026 for (i = 0; i <= AvFILL(ar); i++) {
3027 SV *dirsv = *av_fetch(ar, i, TRUE);
3033 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3034 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3037 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3038 PTR2UV(SvANY(loader)), name);
3039 tryname = SvPVX(namesv);
3050 count = call_sv(loader, G_ARRAY);
3060 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3064 if (SvTYPE(arg) == SVt_PVGV) {
3065 IO *io = GvIO((GV *)arg);
3070 tryrsfp = IoIFP(io);
3071 if (IoTYPE(io) == '|') {
3072 /* reading from a child process doesn't
3073 nest -- when returning from reading
3074 the inner module, the outer one is
3075 unreadable (closed?) I've tried to
3076 save the gv to manage the lifespan of
3077 the pipe, but this didn't help. XXX */
3078 filter_child_proc = (GV *)arg;
3079 (void)SvREFCNT_inc(filter_child_proc);
3082 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3083 PerlIO_close(IoOFP(io));
3095 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3097 (void)SvREFCNT_inc(filter_sub);
3100 filter_state = SP[i];
3101 (void)SvREFCNT_inc(filter_state);
3105 tryrsfp = PerlIO_open("/dev/null",
3119 filter_has_file = 0;
3120 if (filter_child_proc) {
3121 SvREFCNT_dec(filter_child_proc);
3122 filter_child_proc = 0;
3125 SvREFCNT_dec(filter_state);
3129 SvREFCNT_dec(filter_sub);
3134 char *dir = SvPVx(dirsv, n_a);
3135 #ifdef MACOS_TRADITIONAL
3136 /* We have ensured in incpush that library ends with ':' */
3137 Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':'));
3141 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3143 sv_setpv(namesv, unixdir);
3144 sv_catpv(namesv, unixname);
3146 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3149 TAINT_PROPER("require");
3150 tryname = SvPVX(namesv);
3151 #ifdef MACOS_TRADITIONAL
3153 /* Convert slashes in the name part, but not the directory part, to colons */
3155 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3159 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3161 if (tryname[0] == '.' && tryname[1] == '/')
3169 SAVECOPFILE_FREE(&PL_compiling);
3170 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3171 SvREFCNT_dec(namesv);
3173 if (PL_op->op_type == OP_REQUIRE) {
3174 char *msgstr = name;
3175 if (namesv) { /* did we lookup @INC? */
3176 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3177 SV *dirmsgsv = NEWSV(0, 0);
3178 AV *ar = GvAVn(PL_incgv);
3180 sv_catpvn(msg, " in @INC", 8);
3181 if (instr(SvPVX(msg), ".h "))
3182 sv_catpv(msg, " (change .h to .ph maybe?)");
3183 if (instr(SvPVX(msg), ".ph "))
3184 sv_catpv(msg, " (did you run h2ph?)");
3185 sv_catpv(msg, " (@INC contains:");
3186 for (i = 0; i <= AvFILL(ar); i++) {
3187 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3188 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3189 sv_catsv(msg, dirmsgsv);
3191 sv_catpvn(msg, ")", 1);
3192 SvREFCNT_dec(dirmsgsv);
3193 msgstr = SvPV_nolen(msg);
3195 DIE(aTHX_ "Can't locate %s", msgstr);
3201 SETERRNO(0, SS$_NORMAL);
3203 /* Assume success here to prevent recursive requirement. */
3204 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3205 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3209 lex_start(sv_2mortal(newSVpvn("",0)));
3210 SAVEGENERICSV(PL_rsfp_filters);
3211 PL_rsfp_filters = Nullav;
3216 SAVESPTR(PL_compiling.cop_warnings);
3217 if (PL_dowarn & G_WARN_ALL_ON)
3218 PL_compiling.cop_warnings = pWARN_ALL ;
3219 else if (PL_dowarn & G_WARN_ALL_OFF)
3220 PL_compiling.cop_warnings = pWARN_NONE ;
3222 PL_compiling.cop_warnings = pWARN_STD ;
3224 if (filter_sub || filter_child_proc) {
3225 SV *datasv = filter_add(run_user_filter, Nullsv);
3226 IoLINES(datasv) = filter_has_file;
3227 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3228 IoTOP_GV(datasv) = (GV *)filter_state;
3229 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3232 /* switch to eval mode */
3233 push_return(PL_op->op_next);
3234 PUSHBLOCK(cx, CXt_EVAL, SP);
3235 PUSHEVAL(cx, name, Nullgv);
3237 SAVECOPLINE(&PL_compiling);
3238 CopLINE_set(&PL_compiling, 0);
3242 MUTEX_LOCK(&PL_eval_mutex);
3243 if (PL_eval_owner && PL_eval_owner != thr)
3244 while (PL_eval_owner)
3245 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3246 PL_eval_owner = thr;
3247 MUTEX_UNLOCK(&PL_eval_mutex);
3248 #endif /* USE_THREADS */
3249 return DOCATCH(doeval(G_SCALAR, NULL));
3254 return pp_require();
3260 register PERL_CONTEXT *cx;
3262 I32 gimme = GIMME_V, was = PL_sub_generation;
3263 char tbuf[TYPE_DIGITS(long) + 12];
3264 char *tmpbuf = tbuf;
3269 if (!SvPV(sv,len) || !len)
3271 TAINT_PROPER("eval");
3277 /* switch to eval mode */
3279 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3280 SV *sv = sv_newmortal();
3281 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3282 (unsigned long)++PL_evalseq,
3283 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3287 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3288 SAVECOPFILE_FREE(&PL_compiling);
3289 CopFILE_set(&PL_compiling, tmpbuf+2);
3290 SAVECOPLINE(&PL_compiling);
3291 CopLINE_set(&PL_compiling, 1);
3292 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3293 deleting the eval's FILEGV from the stash before gv_check() runs
3294 (i.e. before run-time proper). To work around the coredump that
3295 ensues, we always turn GvMULTI_on for any globals that were
3296 introduced within evals. See force_ident(). GSAR 96-10-12 */
3297 safestr = savepv(tmpbuf);
3298 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3300 PL_hints = PL_op->op_targ;
3301 SAVESPTR(PL_compiling.cop_warnings);
3302 if (specialWARN(PL_curcop->cop_warnings))
3303 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3305 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3306 SAVEFREESV(PL_compiling.cop_warnings);
3309 push_return(PL_op->op_next);
3310 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3311 PUSHEVAL(cx, 0, Nullgv);
3313 /* prepare to compile string */
3315 if (PERLDB_LINE && PL_curstash != PL_debstash)
3316 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3319 MUTEX_LOCK(&PL_eval_mutex);
3320 if (PL_eval_owner && PL_eval_owner != thr)
3321 while (PL_eval_owner)
3322 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3323 PL_eval_owner = thr;
3324 MUTEX_UNLOCK(&PL_eval_mutex);
3325 #endif /* USE_THREADS */
3326 ret = doeval(gimme, NULL);
3327 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3328 && ret != PL_op->op_next) { /* Successive compilation. */
3329 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3331 return DOCATCH(ret);
3341 register PERL_CONTEXT *cx;
3343 U8 save_flags = PL_op -> op_flags;
3348 retop = pop_return();
3351 if (gimme == G_VOID)
3353 else if (gimme == G_SCALAR) {
3356 if (SvFLAGS(TOPs) & SVs_TEMP)
3359 *MARK = sv_mortalcopy(TOPs);
3363 *MARK = &PL_sv_undef;
3368 /* in case LEAVE wipes old return values */
3369 for (mark = newsp + 1; mark <= SP; mark++) {
3370 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3371 *mark = sv_mortalcopy(*mark);
3372 TAINT_NOT; /* Each item is independent */
3376 PL_curpm = newpm; /* Don't pop $1 et al till now */
3378 if (AvFILLp(PL_comppad_name) >= 0)
3382 assert(CvDEPTH(PL_compcv) == 1);
3384 CvDEPTH(PL_compcv) = 0;
3387 if (optype == OP_REQUIRE &&
3388 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3390 /* Unassume the success we assumed earlier. */
3391 SV *nsv = cx->blk_eval.old_namesv;
3392 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3393 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3394 /* die_where() did LEAVE, or we won't be here */
3398 if (!(save_flags & OPf_SPECIAL))
3408 register PERL_CONTEXT *cx;
3409 I32 gimme = GIMME_V;
3414 push_return(cLOGOP->op_other->op_next);
3415 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3417 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3419 PL_in_eval = EVAL_INEVAL;
3422 return DOCATCH(PL_op->op_next);
3432 register PERL_CONTEXT *cx;
3440 if (gimme == G_VOID)
3442 else if (gimme == G_SCALAR) {
3445 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3448 *MARK = sv_mortalcopy(TOPs);
3452 *MARK = &PL_sv_undef;
3457 /* in case LEAVE wipes old return values */
3458 for (mark = newsp + 1; mark <= SP; mark++) {
3459 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3460 *mark = sv_mortalcopy(*mark);
3461 TAINT_NOT; /* Each item is independent */
3465 PL_curpm = newpm; /* Don't pop $1 et al till now */
3473 S_doparseform(pTHX_ SV *sv)
3476 register char *s = SvPV_force(sv, len);
3477 register char *send = s + len;
3478 register char *base;
3479 register I32 skipspaces = 0;
3482 bool postspace = FALSE;
3490 Perl_croak(aTHX_ "Null picture in formline");
3492 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3497 *fpc++ = FF_LINEMARK;
3498 noblank = repeat = FALSE;
3516 case ' ': case '\t':
3527 *fpc++ = FF_LITERAL;
3535 *fpc++ = skipspaces;
3539 *fpc++ = FF_NEWLINE;
3543 arg = fpc - linepc + 1;
3550 *fpc++ = FF_LINEMARK;
3551 noblank = repeat = FALSE;
3560 ischop = s[-1] == '^';
3566 arg = (s - base) - 1;
3568 *fpc++ = FF_LITERAL;
3577 *fpc++ = FF_LINEGLOB;
3579 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3580 arg = ischop ? 512 : 0;
3590 arg |= 256 + (s - f);
3592 *fpc++ = s - base; /* fieldsize for FETCH */
3593 *fpc++ = FF_DECIMAL;
3598 bool ismore = FALSE;
3601 while (*++s == '>') ;
3602 prespace = FF_SPACE;
3604 else if (*s == '|') {
3605 while (*++s == '|') ;
3606 prespace = FF_HALFSPACE;
3611 while (*++s == '<') ;
3614 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3618 *fpc++ = s - base; /* fieldsize for FETCH */
3620 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3638 { /* need to jump to the next word */
3640 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3641 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3642 s = SvPVX(sv) + SvCUR(sv) + z;
3644 Copy(fops, s, arg, U16);
3646 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3651 * The rest of this file was derived from source code contributed
3654 * NOTE: this code was derived from Tom Horsley's qsort replacement
3655 * and should not be confused with the original code.
3658 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3660 Permission granted to distribute under the same terms as perl which are
3663 This program is free software; you can redistribute it and/or modify
3664 it under the terms of either:
3666 a) the GNU General Public License as published by the Free
3667 Software Foundation; either version 1, or (at your option) any
3670 b) the "Artistic License" which comes with this Kit.
3672 Details on the perl license can be found in the perl source code which
3673 may be located via the www.perl.com web page.
3675 This is the most wonderfulest possible qsort I can come up with (and
3676 still be mostly portable) My (limited) tests indicate it consistently
3677 does about 20% fewer calls to compare than does the qsort in the Visual
3678 C++ library, other vendors may vary.
3680 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3681 others I invented myself (or more likely re-invented since they seemed
3682 pretty obvious once I watched the algorithm operate for a while).
3684 Most of this code was written while watching the Marlins sweep the Giants
3685 in the 1997 National League Playoffs - no Braves fans allowed to use this
3686 code (just kidding :-).
3688 I realize that if I wanted to be true to the perl tradition, the only
3689 comment in this file would be something like:
3691 ...they shuffled back towards the rear of the line. 'No, not at the
3692 rear!' the slave-driver shouted. 'Three files up. And stay there...
3694 However, I really needed to violate that tradition just so I could keep
3695 track of what happens myself, not to mention some poor fool trying to
3696 understand this years from now :-).
3699 /* ********************************************************** Configuration */
3701 #ifndef QSORT_ORDER_GUESS
3702 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3705 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3706 future processing - a good max upper bound is log base 2 of memory size
3707 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3708 safely be smaller than that since the program is taking up some space and
3709 most operating systems only let you grab some subset of contiguous
3710 memory (not to mention that you are normally sorting data larger than
3711 1 byte element size :-).
3713 #ifndef QSORT_MAX_STACK
3714 #define QSORT_MAX_STACK 32
3717 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3718 Anything bigger and we use qsort. If you make this too small, the qsort
3719 will probably break (or become less efficient), because it doesn't expect
3720 the middle element of a partition to be the same as the right or left -
3721 you have been warned).
3723 #ifndef QSORT_BREAK_EVEN
3724 #define QSORT_BREAK_EVEN 6
3727 /* ************************************************************* Data Types */
3729 /* hold left and right index values of a partition waiting to be sorted (the
3730 partition includes both left and right - right is NOT one past the end or
3731 anything like that).
3733 struct partition_stack_entry {
3736 #ifdef QSORT_ORDER_GUESS
3737 int qsort_break_even;
3741 /* ******************************************************* Shorthand Macros */
3743 /* Note that these macros will be used from inside the qsort function where
3744 we happen to know that the variable 'elt_size' contains the size of an
3745 array element and the variable 'temp' points to enough space to hold a
3746 temp element and the variable 'array' points to the array being sorted
3747 and 'compare' is the pointer to the compare routine.
3749 Also note that there are very many highly architecture specific ways
3750 these might be sped up, but this is simply the most generally portable
3751 code I could think of.
3754 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3756 #define qsort_cmp(elt1, elt2) \
3757 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3759 #ifdef QSORT_ORDER_GUESS
3760 #define QSORT_NOTICE_SWAP swapped++;
3762 #define QSORT_NOTICE_SWAP
3765 /* swaps contents of array elements elt1, elt2.
3767 #define qsort_swap(elt1, elt2) \
3770 temp = array[elt1]; \
3771 array[elt1] = array[elt2]; \
3772 array[elt2] = temp; \
3775 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3776 elt3 and elt3 gets elt1.
3778 #define qsort_rotate(elt1, elt2, elt3) \
3781 temp = array[elt1]; \
3782 array[elt1] = array[elt2]; \
3783 array[elt2] = array[elt3]; \
3784 array[elt3] = temp; \
3787 /* ************************************************************ Debug stuff */
3794 return; /* good place to set a breakpoint */
3797 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3800 doqsort_all_asserts(
3804 int (*compare)(const void * elt1, const void * elt2),
3805 int pc_left, int pc_right, int u_left, int u_right)
3809 qsort_assert(pc_left <= pc_right);
3810 qsort_assert(u_right < pc_left);
3811 qsort_assert(pc_right < u_left);
3812 for (i = u_right + 1; i < pc_left; ++i) {
3813 qsort_assert(qsort_cmp(i, pc_left) < 0);
3815 for (i = pc_left; i < pc_right; ++i) {
3816 qsort_assert(qsort_cmp(i, pc_right) == 0);
3818 for (i = pc_right + 1; i < u_left; ++i) {
3819 qsort_assert(qsort_cmp(pc_right, i) < 0);
3823 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3824 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3825 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3829 #define qsort_assert(t) ((void)0)
3831 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3835 /* ****************************************************************** qsort */
3838 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3842 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3843 int next_stack_entry = 0;
3847 #ifdef QSORT_ORDER_GUESS
3848 int qsort_break_even;
3852 /* Make sure we actually have work to do.
3854 if (num_elts <= 1) {
3858 /* Setup the initial partition definition and fall into the sorting loop
3861 part_right = (int)(num_elts - 1);
3862 #ifdef QSORT_ORDER_GUESS
3863 qsort_break_even = QSORT_BREAK_EVEN;
3865 #define qsort_break_even QSORT_BREAK_EVEN
3868 if ((part_right - part_left) >= qsort_break_even) {
3869 /* OK, this is gonna get hairy, so lets try to document all the
3870 concepts and abbreviations and variables and what they keep
3873 pc: pivot chunk - the set of array elements we accumulate in the
3874 middle of the partition, all equal in value to the original
3875 pivot element selected. The pc is defined by:
3877 pc_left - the leftmost array index of the pc
3878 pc_right - the rightmost array index of the pc
3880 we start with pc_left == pc_right and only one element
3881 in the pivot chunk (but it can grow during the scan).
3883 u: uncompared elements - the set of elements in the partition
3884 we have not yet compared to the pivot value. There are two
3885 uncompared sets during the scan - one to the left of the pc
3886 and one to the right.
3888 u_right - the rightmost index of the left side's uncompared set
3889 u_left - the leftmost index of the right side's uncompared set
3891 The leftmost index of the left sides's uncompared set
3892 doesn't need its own variable because it is always defined
3893 by the leftmost edge of the whole partition (part_left). The
3894 same goes for the rightmost edge of the right partition
3897 We know there are no uncompared elements on the left once we
3898 get u_right < part_left and no uncompared elements on the
3899 right once u_left > part_right. When both these conditions
3900 are met, we have completed the scan of the partition.
3902 Any elements which are between the pivot chunk and the
3903 uncompared elements should be less than the pivot value on
3904 the left side and greater than the pivot value on the right
3905 side (in fact, the goal of the whole algorithm is to arrange
3906 for that to be true and make the groups of less-than and
3907 greater-then elements into new partitions to sort again).
3909 As you marvel at the complexity of the code and wonder why it
3910 has to be so confusing. Consider some of the things this level
3911 of confusion brings:
3913 Once I do a compare, I squeeze every ounce of juice out of it. I
3914 never do compare calls I don't have to do, and I certainly never
3917 I also never swap any elements unless I can prove there is a
3918 good reason. Many sort algorithms will swap a known value with
3919 an uncompared value just to get things in the right place (or
3920 avoid complexity :-), but that uncompared value, once it gets
3921 compared, may then have to be swapped again. A lot of the
3922 complexity of this code is due to the fact that it never swaps
3923 anything except compared values, and it only swaps them when the
3924 compare shows they are out of position.
3926 int pc_left, pc_right;
3927 int u_right, u_left;
3931 pc_left = ((part_left + part_right) / 2);
3933 u_right = pc_left - 1;
3934 u_left = pc_right + 1;
3936 /* Qsort works best when the pivot value is also the median value
3937 in the partition (unfortunately you can't find the median value
3938 without first sorting :-), so to give the algorithm a helping
3939 hand, we pick 3 elements and sort them and use the median value
3940 of that tiny set as the pivot value.
3942 Some versions of qsort like to use the left middle and right as
3943 the 3 elements to sort so they can insure the ends of the
3944 partition will contain values which will stop the scan in the
3945 compare loop, but when you have to call an arbitrarily complex
3946 routine to do a compare, its really better to just keep track of
3947 array index values to know when you hit the edge of the
3948 partition and avoid the extra compare. An even better reason to
3949 avoid using a compare call is the fact that you can drop off the
3950 edge of the array if someone foolishly provides you with an
3951 unstable compare function that doesn't always provide consistent
3954 So, since it is simpler for us to compare the three adjacent
3955 elements in the middle of the partition, those are the ones we
3956 pick here (conveniently pointed at by u_right, pc_left, and
3957 u_left). The values of the left, center, and right elements
3958 are refered to as l c and r in the following comments.
3961 #ifdef QSORT_ORDER_GUESS
3964 s = qsort_cmp(u_right, pc_left);
3967 s = qsort_cmp(pc_left, u_left);
3968 /* if l < c, c < r - already in order - nothing to do */
3970 /* l < c, c == r - already in order, pc grows */
3972 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3974 /* l < c, c > r - need to know more */
3975 s = qsort_cmp(u_right, u_left);
3977 /* l < c, c > r, l < r - swap c & r to get ordered */
3978 qsort_swap(pc_left, u_left);
3979 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3980 } else if (s == 0) {
3981 /* l < c, c > r, l == r - swap c&r, grow pc */
3982 qsort_swap(pc_left, u_left);
3984 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3986 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3987 qsort_rotate(pc_left, u_right, u_left);
3988 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3991 } else if (s == 0) {
3993 s = qsort_cmp(pc_left, u_left);
3995 /* l == c, c < r - already in order, grow pc */
3997 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3998 } else if (s == 0) {
3999 /* l == c, c == r - already in order, grow pc both ways */
4002 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4004 /* l == c, c > r - swap l & r, grow pc */
4005 qsort_swap(u_right, u_left);
4007 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4011 s = qsort_cmp(pc_left, u_left);
4013 /* l > c, c < r - need to know more */
4014 s = qsort_cmp(u_right, u_left);
4016 /* l > c, c < r, l < r - swap l & c to get ordered */
4017 qsort_swap(u_right, pc_left);
4018 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4019 } else if (s == 0) {
4020 /* l > c, c < r, l == r - swap l & c, grow pc */
4021 qsort_swap(u_right, pc_left);
4023 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4025 /* l > c, c < r, l > r - rotate lcr into crl to order */
4026 qsort_rotate(u_right, pc_left, u_left);
4027 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4029 } else if (s == 0) {
4030 /* l > c, c == r - swap ends, grow pc */
4031 qsort_swap(u_right, u_left);
4033 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4035 /* l > c, c > r - swap ends to get in order */
4036 qsort_swap(u_right, u_left);
4037 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4040 /* We now know the 3 middle elements have been compared and
4041 arranged in the desired order, so we can shrink the uncompared
4046 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4048 /* The above massive nested if was the simple part :-). We now have
4049 the middle 3 elements ordered and we need to scan through the
4050 uncompared sets on either side, swapping elements that are on
4051 the wrong side or simply shuffling equal elements around to get
4052 all equal elements into the pivot chunk.
4056 int still_work_on_left;
4057 int still_work_on_right;
4059 /* Scan the uncompared values on the left. If I find a value
4060 equal to the pivot value, move it over so it is adjacent to
4061 the pivot chunk and expand the pivot chunk. If I find a value
4062 less than the pivot value, then just leave it - its already
4063 on the correct side of the partition. If I find a greater
4064 value, then stop the scan.
4066 while ((still_work_on_left = (u_right >= part_left))) {
4067 s = qsort_cmp(u_right, pc_left);
4070 } else if (s == 0) {
4072 if (pc_left != u_right) {
4073 qsort_swap(u_right, pc_left);
4079 qsort_assert(u_right < pc_left);
4080 qsort_assert(pc_left <= pc_right);
4081 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4082 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4085 /* Do a mirror image scan of uncompared values on the right
4087 while ((still_work_on_right = (u_left <= part_right))) {
4088 s = qsort_cmp(pc_right, u_left);
4091 } else if (s == 0) {
4093 if (pc_right != u_left) {
4094 qsort_swap(pc_right, u_left);
4100 qsort_assert(u_left > pc_right);
4101 qsort_assert(pc_left <= pc_right);
4102 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4103 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4106 if (still_work_on_left) {
4107 /* I know I have a value on the left side which needs to be
4108 on the right side, but I need to know more to decide
4109 exactly the best thing to do with it.
4111 if (still_work_on_right) {
4112 /* I know I have values on both side which are out of
4113 position. This is a big win because I kill two birds
4114 with one swap (so to speak). I can advance the
4115 uncompared pointers on both sides after swapping both
4116 of them into the right place.
4118 qsort_swap(u_right, u_left);
4121 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4123 /* I have an out of position value on the left, but the
4124 right is fully scanned, so I "slide" the pivot chunk
4125 and any less-than values left one to make room for the
4126 greater value over on the right. If the out of position
4127 value is immediately adjacent to the pivot chunk (there
4128 are no less-than values), I can do that with a swap,
4129 otherwise, I have to rotate one of the less than values
4130 into the former position of the out of position value
4131 and the right end of the pivot chunk into the left end
4135 if (pc_left == u_right) {
4136 qsort_swap(u_right, pc_right);
4137 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4139 qsort_rotate(u_right, pc_left, pc_right);
4140 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4145 } else if (still_work_on_right) {
4146 /* Mirror image of complex case above: I have an out of
4147 position value on the right, but the left is fully
4148 scanned, so I need to shuffle things around to make room
4149 for the right value on the left.
4152 if (pc_right == u_left) {
4153 qsort_swap(u_left, pc_left);
4154 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4156 qsort_rotate(pc_right, pc_left, u_left);
4157 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4162 /* No more scanning required on either side of partition,
4163 break out of loop and figure out next set of partitions
4169 /* The elements in the pivot chunk are now in the right place. They
4170 will never move or be compared again. All I have to do is decide
4171 what to do with the stuff to the left and right of the pivot
4174 Notes on the QSORT_ORDER_GUESS ifdef code:
4176 1. If I just built these partitions without swapping any (or
4177 very many) elements, there is a chance that the elements are
4178 already ordered properly (being properly ordered will
4179 certainly result in no swapping, but the converse can't be
4182 2. A (properly written) insertion sort will run faster on
4183 already ordered data than qsort will.
4185 3. Perhaps there is some way to make a good guess about
4186 switching to an insertion sort earlier than partition size 6
4187 (for instance - we could save the partition size on the stack
4188 and increase the size each time we find we didn't swap, thus
4189 switching to insertion sort earlier for partitions with a
4190 history of not swapping).
4192 4. Naturally, if I just switch right away, it will make
4193 artificial benchmarks with pure ascending (or descending)
4194 data look really good, but is that a good reason in general?
4198 #ifdef QSORT_ORDER_GUESS
4200 #if QSORT_ORDER_GUESS == 1
4201 qsort_break_even = (part_right - part_left) + 1;
4203 #if QSORT_ORDER_GUESS == 2
4204 qsort_break_even *= 2;
4206 #if QSORT_ORDER_GUESS == 3
4207 int prev_break = qsort_break_even;
4208 qsort_break_even *= qsort_break_even;
4209 if (qsort_break_even < prev_break) {
4210 qsort_break_even = (part_right - part_left) + 1;
4214 qsort_break_even = QSORT_BREAK_EVEN;
4218 if (part_left < pc_left) {
4219 /* There are elements on the left which need more processing.
4220 Check the right as well before deciding what to do.
4222 if (pc_right < part_right) {
4223 /* We have two partitions to be sorted. Stack the biggest one
4224 and process the smallest one on the next iteration. This
4225 minimizes the stack height by insuring that any additional
4226 stack entries must come from the smallest partition which
4227 (because it is smallest) will have the fewest
4228 opportunities to generate additional stack entries.
4230 if ((part_right - pc_right) > (pc_left - part_left)) {
4231 /* stack the right partition, process the left */
4232 partition_stack[next_stack_entry].left = pc_right + 1;
4233 partition_stack[next_stack_entry].right = part_right;
4234 #ifdef QSORT_ORDER_GUESS
4235 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4237 part_right = pc_left - 1;
4239 /* stack the left partition, process the right */
4240 partition_stack[next_stack_entry].left = part_left;
4241 partition_stack[next_stack_entry].right = pc_left - 1;
4242 #ifdef QSORT_ORDER_GUESS
4243 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4245 part_left = pc_right + 1;
4247 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4250 /* The elements on the left are the only remaining elements
4251 that need sorting, arrange for them to be processed as the
4254 part_right = pc_left - 1;
4256 } else if (pc_right < part_right) {
4257 /* There is only one chunk on the right to be sorted, make it
4258 the new partition and loop back around.
4260 part_left = pc_right + 1;
4262 /* This whole partition wound up in the pivot chunk, so
4263 we need to get a new partition off the stack.
4265 if (next_stack_entry == 0) {
4266 /* the stack is empty - we are done */
4270 part_left = partition_stack[next_stack_entry].left;
4271 part_right = partition_stack[next_stack_entry].right;
4272 #ifdef QSORT_ORDER_GUESS
4273 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4277 /* This partition is too small to fool with qsort complexity, just
4278 do an ordinary insertion sort to minimize overhead.
4281 /* Assume 1st element is in right place already, and start checking
4282 at 2nd element to see where it should be inserted.
4284 for (i = part_left + 1; i <= part_right; ++i) {
4286 /* Scan (backwards - just in case 'i' is already in right place)
4287 through the elements already sorted to see if the ith element
4288 belongs ahead of one of them.
4290 for (j = i - 1; j >= part_left; --j) {
4291 if (qsort_cmp(i, j) >= 0) {
4292 /* i belongs right after j
4299 /* Looks like we really need to move some things
4303 for (k = i - 1; k >= j; --k)
4304 array[k + 1] = array[k];
4309 /* That partition is now sorted, grab the next one, or get out
4310 of the loop if there aren't any more.
4313 if (next_stack_entry == 0) {
4314 /* the stack is empty - we are done */
4318 part_left = partition_stack[next_stack_entry].left;
4319 part_right = partition_stack[next_stack_entry].right;
4320 #ifdef QSORT_ORDER_GUESS
4321 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4326 /* Believe it or not, the array is sorted at this point! */
4338 sortcv(pTHXo_ SV *a, SV *b)
4341 I32 oldsaveix = PL_savestack_ix;
4342 I32 oldscopeix = PL_scopestack_ix;
4344 GvSV(PL_firstgv) = a;
4345 GvSV(PL_secondgv) = b;
4346 PL_stack_sp = PL_stack_base;
4349 if (PL_stack_sp != PL_stack_base + 1)
4350 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4351 if (!SvNIOKp(*PL_stack_sp))
4352 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4353 result = SvIV(*PL_stack_sp);
4354 while (PL_scopestack_ix > oldscopeix) {
4357 leave_scope(oldsaveix);
4362 sortcv_stacked(pTHXo_ SV *a, SV *b)
4365 I32 oldsaveix = PL_savestack_ix;
4366 I32 oldscopeix = PL_scopestack_ix;
4371 av = (AV*)PL_curpad[0];
4373 av = GvAV(PL_defgv);
4376 if (AvMAX(av) < 1) {
4377 SV** ary = AvALLOC(av);
4378 if (AvARRAY(av) != ary) {
4379 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4380 SvPVX(av) = (char*)ary;
4382 if (AvMAX(av) < 1) {
4385 SvPVX(av) = (char*)ary;
4392 PL_stack_sp = PL_stack_base;
4395 if (PL_stack_sp != PL_stack_base + 1)
4396 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4397 if (!SvNIOKp(*PL_stack_sp))
4398 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4399 result = SvIV(*PL_stack_sp);
4400 while (PL_scopestack_ix > oldscopeix) {
4403 leave_scope(oldsaveix);
4408 sortcv_xsub(pTHXo_ SV *a, SV *b)
4411 I32 oldsaveix = PL_savestack_ix;
4412 I32 oldscopeix = PL_scopestack_ix;
4414 CV *cv=(CV*)PL_sortcop;
4422 (void)(*CvXSUB(cv))(aTHXo_ cv);
4423 if (PL_stack_sp != PL_stack_base + 1)
4424 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4425 if (!SvNIOKp(*PL_stack_sp))
4426 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4427 result = SvIV(*PL_stack_sp);
4428 while (PL_scopestack_ix > oldscopeix) {
4431 leave_scope(oldsaveix);
4437 sv_ncmp(pTHXo_ SV *a, SV *b)
4441 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4445 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4449 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4451 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4453 if (PL_amagic_generation) { \
4454 if (SvAMAGIC(left)||SvAMAGIC(right))\
4455 *svp = amagic_call(left, \
4463 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4466 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4471 I32 i = SvIVX(tmpsv);
4481 return sv_ncmp(aTHXo_ a, b);
4485 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4488 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4493 I32 i = SvIVX(tmpsv);
4503 return sv_i_ncmp(aTHXo_ a, b);
4507 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4510 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4515 I32 i = SvIVX(tmpsv);
4525 return sv_cmp(str1, str2);
4529 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4532 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4537 I32 i = SvIVX(tmpsv);
4547 return sv_cmp_locale(str1, str2);
4551 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4553 SV *datasv = FILTER_DATA(idx);
4554 int filter_has_file = IoLINES(datasv);
4555 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4556 SV *filter_state = (SV *)IoTOP_GV(datasv);
4557 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4560 /* I was having segfault trouble under Linux 2.2.5 after a
4561 parse error occured. (Had to hack around it with a test
4562 for PL_error_count == 0.) Solaris doesn't segfault --
4563 not sure where the trouble is yet. XXX */
4565 if (filter_has_file) {
4566 len = FILTER_READ(idx+1, buf_sv, maxlen);
4569 if (filter_sub && len >= 0) {
4580 PUSHs(sv_2mortal(newSViv(maxlen)));
4582 PUSHs(filter_state);
4585 count = call_sv(filter_sub, G_SCALAR);
4601 IoLINES(datasv) = 0;
4602 if (filter_child_proc) {
4603 SvREFCNT_dec(filter_child_proc);
4604 IoFMT_GV(datasv) = Nullgv;
4607 SvREFCNT_dec(filter_state);
4608 IoTOP_GV(datasv) = Nullgv;
4611 SvREFCNT_dec(filter_sub);
4612 IoBOTTOM_GV(datasv) = Nullgv;
4614 filter_del(run_user_filter);
4623 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4625 return sv_cmp_locale(str1, str2);
4629 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4631 return sv_cmp(str1, str2);
4634 #endif /* PERL_OBJECT */