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;
894 SAVESPTR(GvSV(PL_firstgv));
895 SAVESPTR(GvSV(PL_secondgv));
898 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
899 if (!(PL_op->op_flags & OPf_SPECIAL)) {
900 cx->cx_type = CXt_SUB;
901 cx->blk_gimme = G_SCALAR;
904 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
906 PL_sortcxix = cxstack_ix;
908 if (hasargs && !is_xsub) {
909 /* This is mostly copied from pp_entersub */
910 AV *av = (AV*)PL_curpad[0];
913 cx->blk_sub.savearray = GvAV(PL_defgv);
914 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
915 #endif /* USE_THREADS */
916 cx->blk_sub.argarray = av;
918 qsortsv((myorigmark+1), max,
919 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
921 POPBLOCK(cx,PL_curpm);
929 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
930 qsortsv(ORIGMARK+1, max,
931 (PL_op->op_private & OPpSORT_NUMERIC)
932 ? ( (PL_op->op_private & OPpSORT_INTEGER)
933 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
934 : ( overloading ? amagic_ncmp : sv_ncmp))
935 : ( (PL_op->op_private & OPpLOCALE)
938 : sv_cmp_locale_static)
939 : ( overloading ? amagic_cmp : sv_cmp_static)));
940 if (PL_op->op_private & OPpSORT_REVERSE) {
942 SV **q = ORIGMARK+max;
952 PL_stack_sp = ORIGMARK + max;
960 if (GIMME == G_ARRAY)
962 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
963 return cLOGOP->op_other;
972 if (GIMME == G_ARRAY) {
973 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
977 SV *targ = PAD_SV(PL_op->op_targ);
979 if ((PL_op->op_private & OPpFLIP_LINENUM)
980 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
982 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
983 if (PL_op->op_flags & OPf_SPECIAL) {
991 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1004 if (GIMME == G_ARRAY) {
1010 if (SvGMAGICAL(left))
1012 if (SvGMAGICAL(right))
1015 if (SvNIOKp(left) || !SvPOKp(left) ||
1016 SvNIOKp(right) || !SvPOKp(right) ||
1017 (looks_like_number(left) && *SvPVX(left) != '0' &&
1018 looks_like_number(right) && *SvPVX(right) != '0'))
1020 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1021 DIE(aTHX_ "Range iterator outside integer range");
1032 sv = sv_2mortal(newSViv(i++));
1037 SV *final = sv_mortalcopy(right);
1039 char *tmps = SvPV(final, len);
1041 sv = sv_mortalcopy(left);
1043 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1045 if (strEQ(SvPVX(sv),tmps))
1047 sv = sv_2mortal(newSVsv(sv));
1054 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1056 if ((PL_op->op_private & OPpFLIP_LINENUM)
1057 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1059 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1060 sv_catpv(targ, "E0");
1071 S_dopoptolabel(pTHX_ char *label)
1075 register PERL_CONTEXT *cx;
1077 for (i = cxstack_ix; i >= 0; i--) {
1079 switch (CxTYPE(cx)) {
1081 if (ckWARN(WARN_EXITING))
1082 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1083 PL_op_name[PL_op->op_type]);
1086 if (ckWARN(WARN_EXITING))
1087 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1088 PL_op_name[PL_op->op_type]);
1091 if (ckWARN(WARN_EXITING))
1092 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1093 PL_op_name[PL_op->op_type]);
1096 if (ckWARN(WARN_EXITING))
1097 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1098 PL_op_name[PL_op->op_type]);
1101 if (ckWARN(WARN_EXITING))
1102 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1103 PL_op_name[PL_op->op_type]);
1106 if (!cx->blk_loop.label ||
1107 strNE(label, cx->blk_loop.label) ) {
1108 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1109 (long)i, cx->blk_loop.label));
1112 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1120 Perl_dowantarray(pTHX)
1122 I32 gimme = block_gimme();
1123 return (gimme == G_VOID) ? G_SCALAR : gimme;
1127 Perl_block_gimme(pTHX)
1132 cxix = dopoptosub(cxstack_ix);
1136 switch (cxstack[cxix].blk_gimme) {
1144 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1151 S_dopoptosub(pTHX_ I32 startingblock)
1154 return dopoptosub_at(cxstack, startingblock);
1158 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1162 register PERL_CONTEXT *cx;
1163 for (i = startingblock; i >= 0; i--) {
1165 switch (CxTYPE(cx)) {
1171 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1179 S_dopoptoeval(pTHX_ I32 startingblock)
1183 register PERL_CONTEXT *cx;
1184 for (i = startingblock; i >= 0; i--) {
1186 switch (CxTYPE(cx)) {
1190 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1198 S_dopoptoloop(pTHX_ I32 startingblock)
1202 register PERL_CONTEXT *cx;
1203 for (i = startingblock; i >= 0; i--) {
1205 switch (CxTYPE(cx)) {
1207 if (ckWARN(WARN_EXITING))
1208 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1209 PL_op_name[PL_op->op_type]);
1212 if (ckWARN(WARN_EXITING))
1213 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1214 PL_op_name[PL_op->op_type]);
1217 if (ckWARN(WARN_EXITING))
1218 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1219 PL_op_name[PL_op->op_type]);
1222 if (ckWARN(WARN_EXITING))
1223 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1224 PL_op_name[PL_op->op_type]);
1227 if (ckWARN(WARN_EXITING))
1228 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1229 PL_op_name[PL_op->op_type]);
1232 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1240 Perl_dounwind(pTHX_ I32 cxix)
1243 register PERL_CONTEXT *cx;
1246 while (cxstack_ix > cxix) {
1248 cx = &cxstack[cxstack_ix];
1249 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1250 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1251 /* Note: we don't need to restore the base context info till the end. */
1252 switch (CxTYPE(cx)) {
1255 continue; /* not break */
1277 * Closures mentioned at top level of eval cannot be referenced
1278 * again, and their presence indirectly causes a memory leak.
1279 * (Note that the fact that compcv and friends are still set here
1280 * is, AFAIK, an accident.) --Chip
1282 * XXX need to get comppad et al from eval's cv rather than
1283 * relying on the incidental global values.
1286 S_free_closures(pTHX)
1289 SV **svp = AvARRAY(PL_comppad_name);
1291 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1293 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1295 svp[ix] = &PL_sv_undef;
1299 SvREFCNT_dec(CvOUTSIDE(sv));
1300 CvOUTSIDE(sv) = Nullcv;
1313 Perl_qerror(pTHX_ SV *err)
1316 sv_catsv(ERRSV, err);
1318 sv_catsv(PL_errors, err);
1320 Perl_warn(aTHX_ "%"SVf, err);
1325 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1330 register PERL_CONTEXT *cx;
1335 if (PL_in_eval & EVAL_KEEPERR) {
1336 static char prefix[] = "\t(in cleanup) ";
1341 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1344 if (*e != *message || strNE(e,message))
1348 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1349 sv_catpvn(err, prefix, sizeof(prefix)-1);
1350 sv_catpvn(err, message, msglen);
1351 if (ckWARN(WARN_MISC)) {
1352 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1353 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1358 sv_setpvn(ERRSV, message, msglen);
1361 message = SvPVx(ERRSV, msglen);
1363 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1364 && PL_curstackinfo->si_prev)
1373 if (cxix < cxstack_ix)
1376 POPBLOCK(cx,PL_curpm);
1377 if (CxTYPE(cx) != CXt_EVAL) {
1378 PerlIO_write(Perl_error_log, "panic: die ", 11);
1379 PerlIO_write(Perl_error_log, message, msglen);
1384 if (gimme == G_SCALAR)
1385 *++newsp = &PL_sv_undef;
1386 PL_stack_sp = newsp;
1390 if (optype == OP_REQUIRE) {
1391 char* msg = SvPVx(ERRSV, n_a);
1392 DIE(aTHX_ "%sCompilation failed in require",
1393 *msg ? msg : "Unknown error\n");
1395 return pop_return();
1399 message = SvPVx(ERRSV, msglen);
1402 /* SFIO can really mess with your errno */
1405 PerlIO *serr = Perl_error_log;
1407 PerlIO_write(serr, message, msglen);
1408 (void)PerlIO_flush(serr);
1421 if (SvTRUE(left) != SvTRUE(right))
1433 RETURNOP(cLOGOP->op_other);
1442 RETURNOP(cLOGOP->op_other);
1448 register I32 cxix = dopoptosub(cxstack_ix);
1449 register PERL_CONTEXT *cx;
1450 register PERL_CONTEXT *ccstack = cxstack;
1451 PERL_SI *top_si = PL_curstackinfo;
1462 /* we may be in a higher stacklevel, so dig down deeper */
1463 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1464 top_si = top_si->si_prev;
1465 ccstack = top_si->si_cxstack;
1466 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1469 if (GIMME != G_ARRAY)
1473 if (PL_DBsub && cxix >= 0 &&
1474 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1478 cxix = dopoptosub_at(ccstack, cxix - 1);
1481 cx = &ccstack[cxix];
1482 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1483 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1484 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1485 field below is defined for any cx. */
1486 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1487 cx = &ccstack[dbcxix];
1490 stashname = CopSTASHPV(cx->blk_oldcop);
1491 if (GIMME != G_ARRAY) {
1493 PUSHs(&PL_sv_undef);
1496 sv_setpv(TARG, stashname);
1503 PUSHs(&PL_sv_undef);
1505 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1506 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1507 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1510 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1511 /* So is ccstack[dbcxix]. */
1513 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1514 PUSHs(sv_2mortal(sv));
1515 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1518 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1519 PUSHs(sv_2mortal(newSViv(0)));
1521 gimme = (I32)cx->blk_gimme;
1522 if (gimme == G_VOID)
1523 PUSHs(&PL_sv_undef);
1525 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1526 if (CxTYPE(cx) == CXt_EVAL) {
1528 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1529 PUSHs(cx->blk_eval.cur_text);
1533 else if (cx->blk_eval.old_namesv) {
1534 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1537 /* eval BLOCK (try blocks have old_namesv == 0) */
1539 PUSHs(&PL_sv_undef);
1540 PUSHs(&PL_sv_undef);
1544 PUSHs(&PL_sv_undef);
1545 PUSHs(&PL_sv_undef);
1547 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1548 && CopSTASH_eq(PL_curcop, PL_debstash))
1550 AV *ary = cx->blk_sub.argarray;
1551 int off = AvARRAY(ary) - AvALLOC(ary);
1555 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1558 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1561 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1562 av_extend(PL_dbargs, AvFILLp(ary) + off);
1563 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1564 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1566 /* XXX only hints propagated via op_private are currently
1567 * visible (others are not easily accessible, since they
1568 * use the global PL_hints) */
1569 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1570 HINT_PRIVATE_MASK)));
1573 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1575 if (old_warnings == pWARN_NONE ||
1576 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1577 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1578 else if (old_warnings == pWARN_ALL ||
1579 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1580 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1582 mask = newSVsv(old_warnings);
1583 PUSHs(sv_2mortal(mask));
1598 sv_reset(tmps, CopSTASH(PL_curcop));
1610 PL_curcop = (COP*)PL_op;
1611 TAINT_NOT; /* Each statement is presumed innocent */
1612 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1615 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1619 register PERL_CONTEXT *cx;
1620 I32 gimme = G_ARRAY;
1627 DIE(aTHX_ "No DB::DB routine defined");
1629 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1641 push_return(PL_op->op_next);
1642 PUSHBLOCK(cx, CXt_SUB, SP);
1645 (void)SvREFCNT_inc(cv);
1646 SAVEVPTR(PL_curpad);
1647 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1648 RETURNOP(CvSTART(cv));
1662 register PERL_CONTEXT *cx;
1663 I32 gimme = GIMME_V;
1665 U32 cxtype = CXt_LOOP;
1674 if (PL_op->op_flags & OPf_SPECIAL) {
1676 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1677 SAVEGENERICSV(*svp);
1681 #endif /* USE_THREADS */
1682 if (PL_op->op_targ) {
1683 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1686 iterdata = (void*)PL_op->op_targ;
1687 cxtype |= CXp_PADVAR;
1692 svp = &GvSV(gv); /* symbol table variable */
1693 SAVEGENERICSV(*svp);
1696 iterdata = (void*)gv;
1702 PUSHBLOCK(cx, cxtype, SP);
1704 PUSHLOOP(cx, iterdata, MARK);
1706 PUSHLOOP(cx, svp, MARK);
1708 if (PL_op->op_flags & OPf_STACKED) {
1709 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1710 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1712 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1713 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1714 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1715 looks_like_number((SV*)cx->blk_loop.iterary) &&
1716 *SvPVX(cx->blk_loop.iterary) != '0'))
1718 if (SvNV(sv) < IV_MIN ||
1719 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1720 DIE(aTHX_ "Range iterator outside integer range");
1721 cx->blk_loop.iterix = SvIV(sv);
1722 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1725 cx->blk_loop.iterlval = newSVsv(sv);
1729 cx->blk_loop.iterary = PL_curstack;
1730 AvFILLp(PL_curstack) = SP - PL_stack_base;
1731 cx->blk_loop.iterix = MARK - PL_stack_base;
1740 register PERL_CONTEXT *cx;
1741 I32 gimme = GIMME_V;
1747 PUSHBLOCK(cx, CXt_LOOP, SP);
1748 PUSHLOOP(cx, 0, SP);
1756 register PERL_CONTEXT *cx;
1764 newsp = PL_stack_base + cx->blk_loop.resetsp;
1767 if (gimme == G_VOID)
1769 else if (gimme == G_SCALAR) {
1771 *++newsp = sv_mortalcopy(*SP);
1773 *++newsp = &PL_sv_undef;
1777 *++newsp = sv_mortalcopy(*++mark);
1778 TAINT_NOT; /* Each item is independent */
1784 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1785 PL_curpm = newpm; /* ... and pop $1 et al */
1797 register PERL_CONTEXT *cx;
1798 bool popsub2 = FALSE;
1799 bool clear_errsv = FALSE;
1806 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1807 if (cxstack_ix == PL_sortcxix
1808 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1810 if (cxstack_ix > PL_sortcxix)
1811 dounwind(PL_sortcxix);
1812 AvARRAY(PL_curstack)[1] = *SP;
1813 PL_stack_sp = PL_stack_base + 1;
1818 cxix = dopoptosub(cxstack_ix);
1820 DIE(aTHX_ "Can't return outside a subroutine");
1821 if (cxix < cxstack_ix)
1825 switch (CxTYPE(cx)) {
1830 if (!(PL_in_eval & EVAL_KEEPERR))
1835 if (AvFILLp(PL_comppad_name) >= 0)
1838 if (optype == OP_REQUIRE &&
1839 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1841 /* Unassume the success we assumed earlier. */
1842 SV *nsv = cx->blk_eval.old_namesv;
1843 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1844 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1851 DIE(aTHX_ "panic: return");
1855 if (gimme == G_SCALAR) {
1858 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1860 *++newsp = SvREFCNT_inc(*SP);
1865 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1867 *++newsp = sv_mortalcopy(sv);
1872 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1875 *++newsp = sv_mortalcopy(*SP);
1878 *++newsp = &PL_sv_undef;
1880 else if (gimme == G_ARRAY) {
1881 while (++MARK <= SP) {
1882 *++newsp = (popsub2 && SvTEMP(*MARK))
1883 ? *MARK : sv_mortalcopy(*MARK);
1884 TAINT_NOT; /* Each item is independent */
1887 PL_stack_sp = newsp;
1889 /* Stack values are safe: */
1891 POPSUB(cx,sv); /* release CV and @_ ... */
1895 PL_curpm = newpm; /* ... and pop $1 et al */
1901 return pop_return();
1908 register PERL_CONTEXT *cx;
1918 if (PL_op->op_flags & OPf_SPECIAL) {
1919 cxix = dopoptoloop(cxstack_ix);
1921 DIE(aTHX_ "Can't \"last\" outside a loop block");
1924 cxix = dopoptolabel(cPVOP->op_pv);
1926 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1928 if (cxix < cxstack_ix)
1933 switch (CxTYPE(cx)) {
1936 newsp = PL_stack_base + cx->blk_loop.resetsp;
1937 nextop = cx->blk_loop.last_op->op_next;
1941 nextop = pop_return();
1945 nextop = pop_return();
1949 nextop = pop_return();
1952 DIE(aTHX_ "panic: last");
1956 if (gimme == G_SCALAR) {
1958 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1959 ? *SP : sv_mortalcopy(*SP);
1961 *++newsp = &PL_sv_undef;
1963 else if (gimme == G_ARRAY) {
1964 while (++MARK <= SP) {
1965 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1966 ? *MARK : sv_mortalcopy(*MARK);
1967 TAINT_NOT; /* Each item is independent */
1973 /* Stack values are safe: */
1976 POPLOOP(cx); /* release loop vars ... */
1980 POPSUB(cx,sv); /* release CV and @_ ... */
1983 PL_curpm = newpm; /* ... and pop $1 et al */
1993 register PERL_CONTEXT *cx;
1996 if (PL_op->op_flags & OPf_SPECIAL) {
1997 cxix = dopoptoloop(cxstack_ix);
1999 DIE(aTHX_ "Can't \"next\" outside a loop block");
2002 cxix = dopoptolabel(cPVOP->op_pv);
2004 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2006 if (cxix < cxstack_ix)
2009 /* clear off anything above the scope we're re-entering, but
2010 * save the rest until after a possible continue block */
2011 inner = PL_scopestack_ix;
2013 if (PL_scopestack_ix < inner)
2014 leave_scope(PL_scopestack[PL_scopestack_ix]);
2015 return cx->blk_loop.next_op;
2021 register PERL_CONTEXT *cx;
2024 if (PL_op->op_flags & OPf_SPECIAL) {
2025 cxix = dopoptoloop(cxstack_ix);
2027 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2030 cxix = dopoptolabel(cPVOP->op_pv);
2032 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2034 if (cxix < cxstack_ix)
2038 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2039 LEAVE_SCOPE(oldsave);
2040 return cx->blk_loop.redo_op;
2044 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2048 static char too_deep[] = "Target of goto is too deeply nested";
2051 Perl_croak(aTHX_ too_deep);
2052 if (o->op_type == OP_LEAVE ||
2053 o->op_type == OP_SCOPE ||
2054 o->op_type == OP_LEAVELOOP ||
2055 o->op_type == OP_LEAVETRY)
2057 *ops++ = cUNOPo->op_first;
2059 Perl_croak(aTHX_ too_deep);
2062 if (o->op_flags & OPf_KIDS) {
2064 /* First try all the kids at this level, since that's likeliest. */
2065 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2066 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2067 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2070 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2071 if (kid == PL_lastgotoprobe)
2073 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2075 (ops[-1]->op_type != OP_NEXTSTATE &&
2076 ops[-1]->op_type != OP_DBSTATE)))
2078 if ((o = dofindlabel(kid, label, ops, oplimit)))
2097 register PERL_CONTEXT *cx;
2098 #define GOTO_DEPTH 64
2099 OP *enterops[GOTO_DEPTH];
2101 int do_dump = (PL_op->op_type == OP_DUMP);
2102 static char must_have_label[] = "goto must have label";
2105 if (PL_op->op_flags & OPf_STACKED) {
2109 /* This egregious kludge implements goto &subroutine */
2110 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2112 register PERL_CONTEXT *cx;
2113 CV* cv = (CV*)SvRV(sv);
2119 if (!CvROOT(cv) && !CvXSUB(cv)) {
2124 /* autoloaded stub? */
2125 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2127 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2128 GvNAMELEN(gv), FALSE);
2129 if (autogv && (cv = GvCV(autogv)))
2131 tmpstr = sv_newmortal();
2132 gv_efullname3(tmpstr, gv, Nullch);
2133 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2135 DIE(aTHX_ "Goto undefined subroutine");
2138 /* First do some returnish stuff. */
2139 cxix = dopoptosub(cxstack_ix);
2141 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2142 if (cxix < cxstack_ix)
2145 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2146 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2148 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2149 /* put @_ back onto stack */
2150 AV* av = cx->blk_sub.argarray;
2152 items = AvFILLp(av) + 1;
2154 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2155 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2156 PL_stack_sp += items;
2158 SvREFCNT_dec(GvAV(PL_defgv));
2159 GvAV(PL_defgv) = cx->blk_sub.savearray;
2160 #endif /* USE_THREADS */
2161 /* abandon @_ if it got reified */
2163 (void)sv_2mortal((SV*)av); /* delay until return */
2165 av_extend(av, items-1);
2166 AvFLAGS(av) = AVf_REIFY;
2167 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2170 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2173 av = (AV*)PL_curpad[0];
2175 av = GvAV(PL_defgv);
2177 items = AvFILLp(av) + 1;
2179 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2180 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2181 PL_stack_sp += items;
2183 if (CxTYPE(cx) == CXt_SUB &&
2184 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2185 SvREFCNT_dec(cx->blk_sub.cv);
2186 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2187 LEAVE_SCOPE(oldsave);
2189 /* Now do some callish stuff. */
2192 #ifdef PERL_XSUB_OLDSTYLE
2193 if (CvOLDSTYLE(cv)) {
2194 I32 (*fp3)(int,int,int);
2199 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2200 items = (*fp3)(CvXSUBANY(cv).any_i32,
2201 mark - PL_stack_base + 1,
2203 SP = PL_stack_base + items;
2206 #endif /* PERL_XSUB_OLDSTYLE */
2211 PL_stack_sp--; /* There is no cv arg. */
2212 /* Push a mark for the start of arglist */
2214 (void)(*CvXSUB(cv))(aTHXo_ cv);
2215 /* Pop the current context like a decent sub should */
2216 POPBLOCK(cx, PL_curpm);
2217 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2220 return pop_return();
2223 AV* padlist = CvPADLIST(cv);
2224 SV** svp = AvARRAY(padlist);
2225 if (CxTYPE(cx) == CXt_EVAL) {
2226 PL_in_eval = cx->blk_eval.old_in_eval;
2227 PL_eval_root = cx->blk_eval.old_eval_root;
2228 cx->cx_type = CXt_SUB;
2229 cx->blk_sub.hasargs = 0;
2231 cx->blk_sub.cv = cv;
2232 cx->blk_sub.olddepth = CvDEPTH(cv);
2234 if (CvDEPTH(cv) < 2)
2235 (void)SvREFCNT_inc(cv);
2236 else { /* save temporaries on recursion? */
2237 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2238 sub_crush_depth(cv);
2239 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2240 AV *newpad = newAV();
2241 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2242 I32 ix = AvFILLp((AV*)svp[1]);
2243 I32 names_fill = AvFILLp((AV*)svp[0]);
2244 svp = AvARRAY(svp[0]);
2245 for ( ;ix > 0; ix--) {
2246 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2247 char *name = SvPVX(svp[ix]);
2248 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2251 /* outer lexical or anon code */
2252 av_store(newpad, ix,
2253 SvREFCNT_inc(oldpad[ix]) );
2255 else { /* our own lexical */
2257 av_store(newpad, ix, sv = (SV*)newAV());
2258 else if (*name == '%')
2259 av_store(newpad, ix, sv = (SV*)newHV());
2261 av_store(newpad, ix, sv = NEWSV(0,0));
2265 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2266 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2269 av_store(newpad, ix, sv = NEWSV(0,0));
2273 if (cx->blk_sub.hasargs) {
2276 av_store(newpad, 0, (SV*)av);
2277 AvFLAGS(av) = AVf_REIFY;
2279 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2280 AvFILLp(padlist) = CvDEPTH(cv);
2281 svp = AvARRAY(padlist);
2285 if (!cx->blk_sub.hasargs) {
2286 AV* av = (AV*)PL_curpad[0];
2288 items = AvFILLp(av) + 1;
2290 /* Mark is at the end of the stack. */
2292 Copy(AvARRAY(av), SP + 1, items, SV*);
2297 #endif /* USE_THREADS */
2298 SAVEVPTR(PL_curpad);
2299 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2301 if (cx->blk_sub.hasargs)
2302 #endif /* USE_THREADS */
2304 AV* av = (AV*)PL_curpad[0];
2308 cx->blk_sub.savearray = GvAV(PL_defgv);
2309 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2310 #endif /* USE_THREADS */
2311 cx->blk_sub.argarray = av;
2314 if (items >= AvMAX(av) + 1) {
2316 if (AvARRAY(av) != ary) {
2317 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2318 SvPVX(av) = (char*)ary;
2320 if (items >= AvMAX(av) + 1) {
2321 AvMAX(av) = items - 1;
2322 Renew(ary,items+1,SV*);
2324 SvPVX(av) = (char*)ary;
2327 Copy(mark,AvARRAY(av),items,SV*);
2328 AvFILLp(av) = items - 1;
2329 assert(!AvREAL(av));
2336 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2338 * We do not care about using sv to call CV;
2339 * it's for informational purposes only.
2341 SV *sv = GvSV(PL_DBsub);
2344 if (PERLDB_SUB_NN) {
2345 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2348 gv_efullname3(sv, CvGV(cv), Nullch);
2351 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2352 PUSHMARK( PL_stack_sp );
2353 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2357 RETURNOP(CvSTART(cv));
2361 label = SvPV(sv,n_a);
2362 if (!(do_dump || *label))
2363 DIE(aTHX_ must_have_label);
2366 else if (PL_op->op_flags & OPf_SPECIAL) {
2368 DIE(aTHX_ must_have_label);
2371 label = cPVOP->op_pv;
2373 if (label && *label) {
2378 PL_lastgotoprobe = 0;
2380 for (ix = cxstack_ix; ix >= 0; ix--) {
2382 switch (CxTYPE(cx)) {
2384 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2387 gotoprobe = cx->blk_oldcop->op_sibling;
2393 gotoprobe = cx->blk_oldcop->op_sibling;
2395 gotoprobe = PL_main_root;
2398 if (CvDEPTH(cx->blk_sub.cv)) {
2399 gotoprobe = CvROOT(cx->blk_sub.cv);
2405 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2408 DIE(aTHX_ "panic: goto");
2409 gotoprobe = PL_main_root;
2413 retop = dofindlabel(gotoprobe, label,
2414 enterops, enterops + GOTO_DEPTH);
2418 PL_lastgotoprobe = gotoprobe;
2421 DIE(aTHX_ "Can't find label %s", label);
2423 /* pop unwanted frames */
2425 if (ix < cxstack_ix) {
2432 oldsave = PL_scopestack[PL_scopestack_ix];
2433 LEAVE_SCOPE(oldsave);
2436 /* push wanted frames */
2438 if (*enterops && enterops[1]) {
2440 for (ix = 1; enterops[ix]; ix++) {
2441 PL_op = enterops[ix];
2442 /* Eventually we may want to stack the needed arguments
2443 * for each op. For now, we punt on the hard ones. */
2444 if (PL_op->op_type == OP_ENTERITER)
2445 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2446 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2454 if (!retop) retop = PL_main_start;
2456 PL_restartop = retop;
2457 PL_do_undump = TRUE;
2461 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2462 PL_do_undump = FALSE;
2478 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2482 PL_exit_flags |= PERL_EXIT_EXPECTED;
2484 PUSHs(&PL_sv_undef);
2492 NV value = SvNVx(GvSV(cCOP->cop_gv));
2493 register I32 match = I_32(value);
2496 if (((NV)match) > value)
2497 --match; /* was fractional--truncate other way */
2499 match -= cCOP->uop.scop.scop_offset;
2502 else if (match > cCOP->uop.scop.scop_max)
2503 match = cCOP->uop.scop.scop_max;
2504 PL_op = cCOP->uop.scop.scop_next[match];
2514 PL_op = PL_op->op_next; /* can't assume anything */
2517 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2518 match -= cCOP->uop.scop.scop_offset;
2521 else if (match > cCOP->uop.scop.scop_max)
2522 match = cCOP->uop.scop.scop_max;
2523 PL_op = cCOP->uop.scop.scop_next[match];
2532 S_save_lines(pTHX_ AV *array, SV *sv)
2534 register char *s = SvPVX(sv);
2535 register char *send = SvPVX(sv) + SvCUR(sv);
2537 register I32 line = 1;
2539 while (s && s < send) {
2540 SV *tmpstr = NEWSV(85,0);
2542 sv_upgrade(tmpstr, SVt_PVMG);
2543 t = strchr(s, '\n');
2549 sv_setpvn(tmpstr, s, t - s);
2550 av_store(array, line++, tmpstr);
2555 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2557 S_docatch_body(pTHX_ va_list args)
2559 return docatch_body();
2564 S_docatch_body(pTHX)
2571 S_docatch(pTHX_ OP *o)
2576 volatile PERL_SI *cursi = PL_curstackinfo;
2580 assert(CATCH_GET == TRUE);
2583 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2585 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2591 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2597 if (PL_restartop && cursi == PL_curstackinfo) {
2598 PL_op = PL_restartop;
2615 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2616 /* sv Text to convert to OP tree. */
2617 /* startop op_free() this to undo. */
2618 /* code Short string id of the caller. */
2620 dSP; /* Make POPBLOCK work. */
2623 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2627 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2628 char *tmpbuf = tbuf;
2634 /* switch to eval mode */
2636 if (PL_curcop == &PL_compiling) {
2637 SAVECOPSTASH_FREE(&PL_compiling);
2638 CopSTASH_set(&PL_compiling, PL_curstash);
2640 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2641 SV *sv = sv_newmortal();
2642 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2643 code, (unsigned long)++PL_evalseq,
2644 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2648 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2649 SAVECOPFILE_FREE(&PL_compiling);
2650 CopFILE_set(&PL_compiling, tmpbuf+2);
2651 SAVECOPLINE(&PL_compiling);
2652 CopLINE_set(&PL_compiling, 1);
2653 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2654 deleting the eval's FILEGV from the stash before gv_check() runs
2655 (i.e. before run-time proper). To work around the coredump that
2656 ensues, we always turn GvMULTI_on for any globals that were
2657 introduced within evals. See force_ident(). GSAR 96-10-12 */
2658 safestr = savepv(tmpbuf);
2659 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2661 #ifdef OP_IN_REGISTER
2669 PL_op->op_type = OP_ENTEREVAL;
2670 PL_op->op_flags = 0; /* Avoid uninit warning. */
2671 PUSHBLOCK(cx, CXt_EVAL, SP);
2672 PUSHEVAL(cx, 0, Nullgv);
2673 rop = doeval(G_SCALAR, startop);
2674 POPBLOCK(cx,PL_curpm);
2677 (*startop)->op_type = OP_NULL;
2678 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2680 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2682 if (PL_curcop == &PL_compiling)
2683 PL_compiling.op_private = PL_hints;
2684 #ifdef OP_IN_REGISTER
2690 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2692 S_doeval(pTHX_ int gimme, OP** startop)
2700 PL_in_eval = EVAL_INEVAL;
2704 /* set up a scratch pad */
2707 SAVEVPTR(PL_curpad);
2708 SAVESPTR(PL_comppad);
2709 SAVESPTR(PL_comppad_name);
2710 SAVEI32(PL_comppad_name_fill);
2711 SAVEI32(PL_min_intro_pending);
2712 SAVEI32(PL_max_intro_pending);
2715 for (i = cxstack_ix - 1; i >= 0; i--) {
2716 PERL_CONTEXT *cx = &cxstack[i];
2717 if (CxTYPE(cx) == CXt_EVAL)
2719 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2720 caller = cx->blk_sub.cv;
2725 SAVESPTR(PL_compcv);
2726 PL_compcv = (CV*)NEWSV(1104,0);
2727 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2728 CvEVAL_on(PL_compcv);
2730 CvOWNER(PL_compcv) = 0;
2731 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2732 MUTEX_INIT(CvMUTEXP(PL_compcv));
2733 #endif /* USE_THREADS */
2735 PL_comppad = newAV();
2736 av_push(PL_comppad, Nullsv);
2737 PL_curpad = AvARRAY(PL_comppad);
2738 PL_comppad_name = newAV();
2739 PL_comppad_name_fill = 0;
2740 PL_min_intro_pending = 0;
2743 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2744 PL_curpad[0] = (SV*)newAV();
2745 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2746 #endif /* USE_THREADS */
2748 comppadlist = newAV();
2749 AvREAL_off(comppadlist);
2750 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2751 av_store(comppadlist, 1, (SV*)PL_comppad);
2752 CvPADLIST(PL_compcv) = comppadlist;
2755 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2757 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2760 SAVEFREESV(PL_compcv);
2762 /* make sure we compile in the right package */
2764 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2765 SAVESPTR(PL_curstash);
2766 PL_curstash = CopSTASH(PL_curcop);
2768 SAVESPTR(PL_beginav);
2769 PL_beginav = newAV();
2770 SAVEFREESV(PL_beginav);
2771 SAVEI32(PL_error_count);
2773 /* try to compile it */
2775 PL_eval_root = Nullop;
2777 PL_curcop = &PL_compiling;
2778 PL_curcop->cop_arybase = 0;
2779 SvREFCNT_dec(PL_rs);
2780 PL_rs = newSVpvn("\n", 1);
2781 if (saveop && saveop->op_flags & OPf_SPECIAL)
2782 PL_in_eval |= EVAL_KEEPERR;
2785 if (yyparse() || PL_error_count || !PL_eval_root) {
2789 I32 optype = 0; /* Might be reset by POPEVAL. */
2794 op_free(PL_eval_root);
2795 PL_eval_root = Nullop;
2797 SP = PL_stack_base + POPMARK; /* pop original mark */
2799 POPBLOCK(cx,PL_curpm);
2805 if (optype == OP_REQUIRE) {
2806 char* msg = SvPVx(ERRSV, n_a);
2807 DIE(aTHX_ "%sCompilation failed in require",
2808 *msg ? msg : "Unknown error\n");
2811 char* msg = SvPVx(ERRSV, n_a);
2813 POPBLOCK(cx,PL_curpm);
2815 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2816 (*msg ? msg : "Unknown error\n"));
2818 SvREFCNT_dec(PL_rs);
2819 PL_rs = SvREFCNT_inc(PL_nrs);
2821 MUTEX_LOCK(&PL_eval_mutex);
2823 COND_SIGNAL(&PL_eval_cond);
2824 MUTEX_UNLOCK(&PL_eval_mutex);
2825 #endif /* USE_THREADS */
2828 SvREFCNT_dec(PL_rs);
2829 PL_rs = SvREFCNT_inc(PL_nrs);
2830 CopLINE_set(&PL_compiling, 0);
2832 *startop = PL_eval_root;
2833 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2834 CvOUTSIDE(PL_compcv) = Nullcv;
2836 SAVEFREEOP(PL_eval_root);
2838 scalarvoid(PL_eval_root);
2839 else if (gimme & G_ARRAY)
2842 scalar(PL_eval_root);
2844 DEBUG_x(dump_eval());
2846 /* Register with debugger: */
2847 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2848 CV *cv = get_cv("DB::postponed", FALSE);
2852 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2854 call_sv((SV*)cv, G_DISCARD);
2858 /* compiled okay, so do it */
2860 CvDEPTH(PL_compcv) = 1;
2861 SP = PL_stack_base + POPMARK; /* pop original mark */
2862 PL_op = saveop; /* The caller may need it. */
2864 MUTEX_LOCK(&PL_eval_mutex);
2866 COND_SIGNAL(&PL_eval_cond);
2867 MUTEX_UNLOCK(&PL_eval_mutex);
2868 #endif /* USE_THREADS */
2870 RETURNOP(PL_eval_start);
2874 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2876 STRLEN namelen = strlen(name);
2879 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2880 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2881 char *pmc = SvPV_nolen(pmcsv);
2884 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2885 fp = PerlIO_open(name, mode);
2888 if (PerlLIO_stat(name, &pmstat) < 0 ||
2889 pmstat.st_mtime < pmcstat.st_mtime)
2891 fp = PerlIO_open(pmc, mode);
2894 fp = PerlIO_open(name, mode);
2897 SvREFCNT_dec(pmcsv);
2900 fp = PerlIO_open(name, mode);
2908 register PERL_CONTEXT *cx;
2913 SV *namesv = Nullsv;
2915 I32 gimme = G_SCALAR;
2916 PerlIO *tryrsfp = 0;
2918 int filter_has_file = 0;
2919 GV *filter_child_proc = 0;
2920 SV *filter_state = 0;
2925 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2926 UV rev = 0, ver = 0, sver = 0;
2928 U8 *s = (U8*)SvPVX(sv);
2929 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2931 rev = utf8_to_uv(s, &len);
2934 ver = utf8_to_uv(s, &len);
2937 sver = utf8_to_uv(s, &len);
2940 if (PERL_REVISION < rev
2941 || (PERL_REVISION == rev
2942 && (PERL_VERSION < ver
2943 || (PERL_VERSION == ver
2944 && PERL_SUBVERSION < sver))))
2946 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2947 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2948 PERL_VERSION, PERL_SUBVERSION);
2952 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2953 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2954 + ((NV)PERL_SUBVERSION/(NV)1000000)
2955 + 0.00000099 < SvNV(sv))
2959 NV nver = (nrev - rev) * 1000;
2960 UV ver = (UV)(nver + 0.0009);
2961 NV nsver = (nver - ver) * 1000;
2962 UV sver = (UV)(nsver + 0.0009);
2964 /* help out with the "use 5.6" confusion */
2965 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2966 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2967 "this is only v%d.%d.%d, stopped"
2968 " (did you mean v%"UVuf".%"UVuf".0?)",
2969 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2970 PERL_SUBVERSION, rev, ver/100);
2973 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2974 "this is only v%d.%d.%d, stopped",
2975 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2982 name = SvPV(sv, len);
2983 if (!(name && len > 0 && *name))
2984 DIE(aTHX_ "Null filename used");
2985 TAINT_PROPER("require");
2986 if (PL_op->op_type == OP_REQUIRE &&
2987 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2988 *svp != &PL_sv_undef)
2991 /* prepare to compile file */
2993 if (PERL_FILE_IS_ABSOLUTE(name)
2994 || (*name == '.' && (name[1] == '/' ||
2995 (name[1] == '.' && name[2] == '/'))))
2998 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2999 #ifdef MACOS_TRADITIONAL
3000 /* We consider paths of the form :a:b ambiguous and interpret them first
3001 as global then as local
3003 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3012 AV *ar = GvAVn(PL_incgv);
3016 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3019 namesv = NEWSV(806, 0);
3020 for (i = 0; i <= AvFILL(ar); i++) {
3021 SV *dirsv = *av_fetch(ar, i, TRUE);
3027 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3028 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3031 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3032 PTR2UV(SvANY(loader)), name);
3033 tryname = SvPVX(namesv);
3044 count = call_sv(loader, G_ARRAY);
3054 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3058 if (SvTYPE(arg) == SVt_PVGV) {
3059 IO *io = GvIO((GV *)arg);
3064 tryrsfp = IoIFP(io);
3065 if (IoTYPE(io) == '|') {
3066 /* reading from a child process doesn't
3067 nest -- when returning from reading
3068 the inner module, the outer one is
3069 unreadable (closed?) I've tried to
3070 save the gv to manage the lifespan of
3071 the pipe, but this didn't help. XXX */
3072 filter_child_proc = (GV *)arg;
3073 (void)SvREFCNT_inc(filter_child_proc);
3076 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3077 PerlIO_close(IoOFP(io));
3089 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3091 (void)SvREFCNT_inc(filter_sub);
3094 filter_state = SP[i];
3095 (void)SvREFCNT_inc(filter_state);
3099 tryrsfp = PerlIO_open("/dev/null",
3113 filter_has_file = 0;
3114 if (filter_child_proc) {
3115 SvREFCNT_dec(filter_child_proc);
3116 filter_child_proc = 0;
3119 SvREFCNT_dec(filter_state);
3123 SvREFCNT_dec(filter_sub);
3128 char *dir = SvPVx(dirsv, n_a);
3129 #ifdef MACOS_TRADITIONAL
3130 /* We have ensured in incpush that library ends with ':' */
3131 Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':'));
3135 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3137 sv_setpv(namesv, unixdir);
3138 sv_catpv(namesv, unixname);
3140 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3143 TAINT_PROPER("require");
3144 tryname = SvPVX(namesv);
3145 #ifdef MACOS_TRADITIONAL
3147 /* Convert slashes in the name part, but not the directory part, to colons */
3149 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3153 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3155 if (tryname[0] == '.' && tryname[1] == '/')
3163 SAVECOPFILE_FREE(&PL_compiling);
3164 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3165 SvREFCNT_dec(namesv);
3167 if (PL_op->op_type == OP_REQUIRE) {
3168 char *msgstr = name;
3169 if (namesv) { /* did we lookup @INC? */
3170 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3171 SV *dirmsgsv = NEWSV(0, 0);
3172 AV *ar = GvAVn(PL_incgv);
3174 sv_catpvn(msg, " in @INC", 8);
3175 if (instr(SvPVX(msg), ".h "))
3176 sv_catpv(msg, " (change .h to .ph maybe?)");
3177 if (instr(SvPVX(msg), ".ph "))
3178 sv_catpv(msg, " (did you run h2ph?)");
3179 sv_catpv(msg, " (@INC contains:");
3180 for (i = 0; i <= AvFILL(ar); i++) {
3181 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3182 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3183 sv_catsv(msg, dirmsgsv);
3185 sv_catpvn(msg, ")", 1);
3186 SvREFCNT_dec(dirmsgsv);
3187 msgstr = SvPV_nolen(msg);
3189 DIE(aTHX_ "Can't locate %s", msgstr);
3195 SETERRNO(0, SS$_NORMAL);
3197 /* Assume success here to prevent recursive requirement. */
3198 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3199 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3203 lex_start(sv_2mortal(newSVpvn("",0)));
3204 SAVEGENERICSV(PL_rsfp_filters);
3205 PL_rsfp_filters = Nullav;
3210 SAVESPTR(PL_compiling.cop_warnings);
3211 if (PL_dowarn & G_WARN_ALL_ON)
3212 PL_compiling.cop_warnings = pWARN_ALL ;
3213 else if (PL_dowarn & G_WARN_ALL_OFF)
3214 PL_compiling.cop_warnings = pWARN_NONE ;
3216 PL_compiling.cop_warnings = pWARN_STD ;
3218 if (filter_sub || filter_child_proc) {
3219 SV *datasv = filter_add(run_user_filter, Nullsv);
3220 IoLINES(datasv) = filter_has_file;
3221 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3222 IoTOP_GV(datasv) = (GV *)filter_state;
3223 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3226 /* switch to eval mode */
3227 push_return(PL_op->op_next);
3228 PUSHBLOCK(cx, CXt_EVAL, SP);
3229 PUSHEVAL(cx, name, Nullgv);
3231 SAVECOPLINE(&PL_compiling);
3232 CopLINE_set(&PL_compiling, 0);
3236 MUTEX_LOCK(&PL_eval_mutex);
3237 if (PL_eval_owner && PL_eval_owner != thr)
3238 while (PL_eval_owner)
3239 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3240 PL_eval_owner = thr;
3241 MUTEX_UNLOCK(&PL_eval_mutex);
3242 #endif /* USE_THREADS */
3243 return DOCATCH(doeval(G_SCALAR, NULL));
3248 return pp_require();
3254 register PERL_CONTEXT *cx;
3256 I32 gimme = GIMME_V, was = PL_sub_generation;
3257 char tbuf[TYPE_DIGITS(long) + 12];
3258 char *tmpbuf = tbuf;
3263 if (!SvPV(sv,len) || !len)
3265 TAINT_PROPER("eval");
3271 /* switch to eval mode */
3273 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3274 SV *sv = sv_newmortal();
3275 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3276 (unsigned long)++PL_evalseq,
3277 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3281 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3282 SAVECOPFILE_FREE(&PL_compiling);
3283 CopFILE_set(&PL_compiling, tmpbuf+2);
3284 SAVECOPLINE(&PL_compiling);
3285 CopLINE_set(&PL_compiling, 1);
3286 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3287 deleting the eval's FILEGV from the stash before gv_check() runs
3288 (i.e. before run-time proper). To work around the coredump that
3289 ensues, we always turn GvMULTI_on for any globals that were
3290 introduced within evals. See force_ident(). GSAR 96-10-12 */
3291 safestr = savepv(tmpbuf);
3292 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3294 PL_hints = PL_op->op_targ;
3295 SAVESPTR(PL_compiling.cop_warnings);
3296 if (specialWARN(PL_curcop->cop_warnings))
3297 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3299 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3300 SAVEFREESV(PL_compiling.cop_warnings);
3303 push_return(PL_op->op_next);
3304 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3305 PUSHEVAL(cx, 0, Nullgv);
3307 /* prepare to compile string */
3309 if (PERLDB_LINE && PL_curstash != PL_debstash)
3310 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3313 MUTEX_LOCK(&PL_eval_mutex);
3314 if (PL_eval_owner && PL_eval_owner != thr)
3315 while (PL_eval_owner)
3316 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3317 PL_eval_owner = thr;
3318 MUTEX_UNLOCK(&PL_eval_mutex);
3319 #endif /* USE_THREADS */
3320 ret = doeval(gimme, NULL);
3321 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3322 && ret != PL_op->op_next) { /* Successive compilation. */
3323 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3325 return DOCATCH(ret);
3335 register PERL_CONTEXT *cx;
3337 U8 save_flags = PL_op -> op_flags;
3342 retop = pop_return();
3345 if (gimme == G_VOID)
3347 else if (gimme == G_SCALAR) {
3350 if (SvFLAGS(TOPs) & SVs_TEMP)
3353 *MARK = sv_mortalcopy(TOPs);
3357 *MARK = &PL_sv_undef;
3362 /* in case LEAVE wipes old return values */
3363 for (mark = newsp + 1; mark <= SP; mark++) {
3364 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3365 *mark = sv_mortalcopy(*mark);
3366 TAINT_NOT; /* Each item is independent */
3370 PL_curpm = newpm; /* Don't pop $1 et al till now */
3372 if (AvFILLp(PL_comppad_name) >= 0)
3376 assert(CvDEPTH(PL_compcv) == 1);
3378 CvDEPTH(PL_compcv) = 0;
3381 if (optype == OP_REQUIRE &&
3382 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3384 /* Unassume the success we assumed earlier. */
3385 SV *nsv = cx->blk_eval.old_namesv;
3386 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3387 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3388 /* die_where() did LEAVE, or we won't be here */
3392 if (!(save_flags & OPf_SPECIAL))
3402 register PERL_CONTEXT *cx;
3403 I32 gimme = GIMME_V;
3408 push_return(cLOGOP->op_other->op_next);
3409 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3411 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3413 PL_in_eval = EVAL_INEVAL;
3416 return DOCATCH(PL_op->op_next);
3426 register PERL_CONTEXT *cx;
3434 if (gimme == G_VOID)
3436 else if (gimme == G_SCALAR) {
3439 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3442 *MARK = sv_mortalcopy(TOPs);
3446 *MARK = &PL_sv_undef;
3451 /* in case LEAVE wipes old return values */
3452 for (mark = newsp + 1; mark <= SP; mark++) {
3453 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3454 *mark = sv_mortalcopy(*mark);
3455 TAINT_NOT; /* Each item is independent */
3459 PL_curpm = newpm; /* Don't pop $1 et al till now */
3467 S_doparseform(pTHX_ SV *sv)
3470 register char *s = SvPV_force(sv, len);
3471 register char *send = s + len;
3472 register char *base;
3473 register I32 skipspaces = 0;
3476 bool postspace = FALSE;
3484 Perl_croak(aTHX_ "Null picture in formline");
3486 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3491 *fpc++ = FF_LINEMARK;
3492 noblank = repeat = FALSE;
3510 case ' ': case '\t':
3521 *fpc++ = FF_LITERAL;
3529 *fpc++ = skipspaces;
3533 *fpc++ = FF_NEWLINE;
3537 arg = fpc - linepc + 1;
3544 *fpc++ = FF_LINEMARK;
3545 noblank = repeat = FALSE;
3554 ischop = s[-1] == '^';
3560 arg = (s - base) - 1;
3562 *fpc++ = FF_LITERAL;
3571 *fpc++ = FF_LINEGLOB;
3573 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3574 arg = ischop ? 512 : 0;
3584 arg |= 256 + (s - f);
3586 *fpc++ = s - base; /* fieldsize for FETCH */
3587 *fpc++ = FF_DECIMAL;
3592 bool ismore = FALSE;
3595 while (*++s == '>') ;
3596 prespace = FF_SPACE;
3598 else if (*s == '|') {
3599 while (*++s == '|') ;
3600 prespace = FF_HALFSPACE;
3605 while (*++s == '<') ;
3608 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3612 *fpc++ = s - base; /* fieldsize for FETCH */
3614 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3632 { /* need to jump to the next word */
3634 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3635 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3636 s = SvPVX(sv) + SvCUR(sv) + z;
3638 Copy(fops, s, arg, U16);
3640 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3645 * The rest of this file was derived from source code contributed
3648 * NOTE: this code was derived from Tom Horsley's qsort replacement
3649 * and should not be confused with the original code.
3652 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3654 Permission granted to distribute under the same terms as perl which are
3657 This program is free software; you can redistribute it and/or modify
3658 it under the terms of either:
3660 a) the GNU General Public License as published by the Free
3661 Software Foundation; either version 1, or (at your option) any
3664 b) the "Artistic License" which comes with this Kit.
3666 Details on the perl license can be found in the perl source code which
3667 may be located via the www.perl.com web page.
3669 This is the most wonderfulest possible qsort I can come up with (and
3670 still be mostly portable) My (limited) tests indicate it consistently
3671 does about 20% fewer calls to compare than does the qsort in the Visual
3672 C++ library, other vendors may vary.
3674 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3675 others I invented myself (or more likely re-invented since they seemed
3676 pretty obvious once I watched the algorithm operate for a while).
3678 Most of this code was written while watching the Marlins sweep the Giants
3679 in the 1997 National League Playoffs - no Braves fans allowed to use this
3680 code (just kidding :-).
3682 I realize that if I wanted to be true to the perl tradition, the only
3683 comment in this file would be something like:
3685 ...they shuffled back towards the rear of the line. 'No, not at the
3686 rear!' the slave-driver shouted. 'Three files up. And stay there...
3688 However, I really needed to violate that tradition just so I could keep
3689 track of what happens myself, not to mention some poor fool trying to
3690 understand this years from now :-).
3693 /* ********************************************************** Configuration */
3695 #ifndef QSORT_ORDER_GUESS
3696 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3699 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3700 future processing - a good max upper bound is log base 2 of memory size
3701 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3702 safely be smaller than that since the program is taking up some space and
3703 most operating systems only let you grab some subset of contiguous
3704 memory (not to mention that you are normally sorting data larger than
3705 1 byte element size :-).
3707 #ifndef QSORT_MAX_STACK
3708 #define QSORT_MAX_STACK 32
3711 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3712 Anything bigger and we use qsort. If you make this too small, the qsort
3713 will probably break (or become less efficient), because it doesn't expect
3714 the middle element of a partition to be the same as the right or left -
3715 you have been warned).
3717 #ifndef QSORT_BREAK_EVEN
3718 #define QSORT_BREAK_EVEN 6
3721 /* ************************************************************* Data Types */
3723 /* hold left and right index values of a partition waiting to be sorted (the
3724 partition includes both left and right - right is NOT one past the end or
3725 anything like that).
3727 struct partition_stack_entry {
3730 #ifdef QSORT_ORDER_GUESS
3731 int qsort_break_even;
3735 /* ******************************************************* Shorthand Macros */
3737 /* Note that these macros will be used from inside the qsort function where
3738 we happen to know that the variable 'elt_size' contains the size of an
3739 array element and the variable 'temp' points to enough space to hold a
3740 temp element and the variable 'array' points to the array being sorted
3741 and 'compare' is the pointer to the compare routine.
3743 Also note that there are very many highly architecture specific ways
3744 these might be sped up, but this is simply the most generally portable
3745 code I could think of.
3748 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3750 #define qsort_cmp(elt1, elt2) \
3751 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3753 #ifdef QSORT_ORDER_GUESS
3754 #define QSORT_NOTICE_SWAP swapped++;
3756 #define QSORT_NOTICE_SWAP
3759 /* swaps contents of array elements elt1, elt2.
3761 #define qsort_swap(elt1, elt2) \
3764 temp = array[elt1]; \
3765 array[elt1] = array[elt2]; \
3766 array[elt2] = temp; \
3769 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3770 elt3 and elt3 gets elt1.
3772 #define qsort_rotate(elt1, elt2, elt3) \
3775 temp = array[elt1]; \
3776 array[elt1] = array[elt2]; \
3777 array[elt2] = array[elt3]; \
3778 array[elt3] = temp; \
3781 /* ************************************************************ Debug stuff */
3788 return; /* good place to set a breakpoint */
3791 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3794 doqsort_all_asserts(
3798 int (*compare)(const void * elt1, const void * elt2),
3799 int pc_left, int pc_right, int u_left, int u_right)
3803 qsort_assert(pc_left <= pc_right);
3804 qsort_assert(u_right < pc_left);
3805 qsort_assert(pc_right < u_left);
3806 for (i = u_right + 1; i < pc_left; ++i) {
3807 qsort_assert(qsort_cmp(i, pc_left) < 0);
3809 for (i = pc_left; i < pc_right; ++i) {
3810 qsort_assert(qsort_cmp(i, pc_right) == 0);
3812 for (i = pc_right + 1; i < u_left; ++i) {
3813 qsort_assert(qsort_cmp(pc_right, i) < 0);
3817 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3818 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3819 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3823 #define qsort_assert(t) ((void)0)
3825 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3829 /* ****************************************************************** qsort */
3832 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3836 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3837 int next_stack_entry = 0;
3841 #ifdef QSORT_ORDER_GUESS
3842 int qsort_break_even;
3846 /* Make sure we actually have work to do.
3848 if (num_elts <= 1) {
3852 /* Setup the initial partition definition and fall into the sorting loop
3855 part_right = (int)(num_elts - 1);
3856 #ifdef QSORT_ORDER_GUESS
3857 qsort_break_even = QSORT_BREAK_EVEN;
3859 #define qsort_break_even QSORT_BREAK_EVEN
3862 if ((part_right - part_left) >= qsort_break_even) {
3863 /* OK, this is gonna get hairy, so lets try to document all the
3864 concepts and abbreviations and variables and what they keep
3867 pc: pivot chunk - the set of array elements we accumulate in the
3868 middle of the partition, all equal in value to the original
3869 pivot element selected. The pc is defined by:
3871 pc_left - the leftmost array index of the pc
3872 pc_right - the rightmost array index of the pc
3874 we start with pc_left == pc_right and only one element
3875 in the pivot chunk (but it can grow during the scan).
3877 u: uncompared elements - the set of elements in the partition
3878 we have not yet compared to the pivot value. There are two
3879 uncompared sets during the scan - one to the left of the pc
3880 and one to the right.
3882 u_right - the rightmost index of the left side's uncompared set
3883 u_left - the leftmost index of the right side's uncompared set
3885 The leftmost index of the left sides's uncompared set
3886 doesn't need its own variable because it is always defined
3887 by the leftmost edge of the whole partition (part_left). The
3888 same goes for the rightmost edge of the right partition
3891 We know there are no uncompared elements on the left once we
3892 get u_right < part_left and no uncompared elements on the
3893 right once u_left > part_right. When both these conditions
3894 are met, we have completed the scan of the partition.
3896 Any elements which are between the pivot chunk and the
3897 uncompared elements should be less than the pivot value on
3898 the left side and greater than the pivot value on the right
3899 side (in fact, the goal of the whole algorithm is to arrange
3900 for that to be true and make the groups of less-than and
3901 greater-then elements into new partitions to sort again).
3903 As you marvel at the complexity of the code and wonder why it
3904 has to be so confusing. Consider some of the things this level
3905 of confusion brings:
3907 Once I do a compare, I squeeze every ounce of juice out of it. I
3908 never do compare calls I don't have to do, and I certainly never
3911 I also never swap any elements unless I can prove there is a
3912 good reason. Many sort algorithms will swap a known value with
3913 an uncompared value just to get things in the right place (or
3914 avoid complexity :-), but that uncompared value, once it gets
3915 compared, may then have to be swapped again. A lot of the
3916 complexity of this code is due to the fact that it never swaps
3917 anything except compared values, and it only swaps them when the
3918 compare shows they are out of position.
3920 int pc_left, pc_right;
3921 int u_right, u_left;
3925 pc_left = ((part_left + part_right) / 2);
3927 u_right = pc_left - 1;
3928 u_left = pc_right + 1;
3930 /* Qsort works best when the pivot value is also the median value
3931 in the partition (unfortunately you can't find the median value
3932 without first sorting :-), so to give the algorithm a helping
3933 hand, we pick 3 elements and sort them and use the median value
3934 of that tiny set as the pivot value.
3936 Some versions of qsort like to use the left middle and right as
3937 the 3 elements to sort so they can insure the ends of the
3938 partition will contain values which will stop the scan in the
3939 compare loop, but when you have to call an arbitrarily complex
3940 routine to do a compare, its really better to just keep track of
3941 array index values to know when you hit the edge of the
3942 partition and avoid the extra compare. An even better reason to
3943 avoid using a compare call is the fact that you can drop off the
3944 edge of the array if someone foolishly provides you with an
3945 unstable compare function that doesn't always provide consistent
3948 So, since it is simpler for us to compare the three adjacent
3949 elements in the middle of the partition, those are the ones we
3950 pick here (conveniently pointed at by u_right, pc_left, and
3951 u_left). The values of the left, center, and right elements
3952 are refered to as l c and r in the following comments.
3955 #ifdef QSORT_ORDER_GUESS
3958 s = qsort_cmp(u_right, pc_left);
3961 s = qsort_cmp(pc_left, u_left);
3962 /* if l < c, c < r - already in order - nothing to do */
3964 /* l < c, c == r - already in order, pc grows */
3966 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3968 /* l < c, c > r - need to know more */
3969 s = qsort_cmp(u_right, u_left);
3971 /* l < c, c > r, l < r - swap c & r to get ordered */
3972 qsort_swap(pc_left, u_left);
3973 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3974 } else if (s == 0) {
3975 /* l < c, c > r, l == r - swap c&r, grow pc */
3976 qsort_swap(pc_left, u_left);
3978 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3980 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3981 qsort_rotate(pc_left, u_right, u_left);
3982 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3985 } else if (s == 0) {
3987 s = qsort_cmp(pc_left, u_left);
3989 /* l == c, c < r - already in order, grow pc */
3991 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3992 } else if (s == 0) {
3993 /* l == c, c == r - already in order, grow pc both ways */
3996 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3998 /* l == c, c > r - swap l & r, grow pc */
3999 qsort_swap(u_right, u_left);
4001 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4005 s = qsort_cmp(pc_left, u_left);
4007 /* l > c, c < r - need to know more */
4008 s = qsort_cmp(u_right, u_left);
4010 /* l > c, c < r, l < r - swap l & c to get ordered */
4011 qsort_swap(u_right, pc_left);
4012 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4013 } else if (s == 0) {
4014 /* l > c, c < r, l == r - swap l & c, grow pc */
4015 qsort_swap(u_right, pc_left);
4017 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4019 /* l > c, c < r, l > r - rotate lcr into crl to order */
4020 qsort_rotate(u_right, pc_left, u_left);
4021 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4023 } else if (s == 0) {
4024 /* l > c, c == r - swap ends, grow pc */
4025 qsort_swap(u_right, u_left);
4027 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4029 /* l > c, c > r - swap ends to get in order */
4030 qsort_swap(u_right, u_left);
4031 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4034 /* We now know the 3 middle elements have been compared and
4035 arranged in the desired order, so we can shrink the uncompared
4040 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4042 /* The above massive nested if was the simple part :-). We now have
4043 the middle 3 elements ordered and we need to scan through the
4044 uncompared sets on either side, swapping elements that are on
4045 the wrong side or simply shuffling equal elements around to get
4046 all equal elements into the pivot chunk.
4050 int still_work_on_left;
4051 int still_work_on_right;
4053 /* Scan the uncompared values on the left. If I find a value
4054 equal to the pivot value, move it over so it is adjacent to
4055 the pivot chunk and expand the pivot chunk. If I find a value
4056 less than the pivot value, then just leave it - its already
4057 on the correct side of the partition. If I find a greater
4058 value, then stop the scan.
4060 while ((still_work_on_left = (u_right >= part_left))) {
4061 s = qsort_cmp(u_right, pc_left);
4064 } else if (s == 0) {
4066 if (pc_left != u_right) {
4067 qsort_swap(u_right, pc_left);
4073 qsort_assert(u_right < pc_left);
4074 qsort_assert(pc_left <= pc_right);
4075 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4076 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4079 /* Do a mirror image scan of uncompared values on the right
4081 while ((still_work_on_right = (u_left <= part_right))) {
4082 s = qsort_cmp(pc_right, u_left);
4085 } else if (s == 0) {
4087 if (pc_right != u_left) {
4088 qsort_swap(pc_right, u_left);
4094 qsort_assert(u_left > pc_right);
4095 qsort_assert(pc_left <= pc_right);
4096 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4097 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4100 if (still_work_on_left) {
4101 /* I know I have a value on the left side which needs to be
4102 on the right side, but I need to know more to decide
4103 exactly the best thing to do with it.
4105 if (still_work_on_right) {
4106 /* I know I have values on both side which are out of
4107 position. This is a big win because I kill two birds
4108 with one swap (so to speak). I can advance the
4109 uncompared pointers on both sides after swapping both
4110 of them into the right place.
4112 qsort_swap(u_right, u_left);
4115 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4117 /* I have an out of position value on the left, but the
4118 right is fully scanned, so I "slide" the pivot chunk
4119 and any less-than values left one to make room for the
4120 greater value over on the right. If the out of position
4121 value is immediately adjacent to the pivot chunk (there
4122 are no less-than values), I can do that with a swap,
4123 otherwise, I have to rotate one of the less than values
4124 into the former position of the out of position value
4125 and the right end of the pivot chunk into the left end
4129 if (pc_left == u_right) {
4130 qsort_swap(u_right, pc_right);
4131 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4133 qsort_rotate(u_right, pc_left, pc_right);
4134 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4139 } else if (still_work_on_right) {
4140 /* Mirror image of complex case above: I have an out of
4141 position value on the right, but the left is fully
4142 scanned, so I need to shuffle things around to make room
4143 for the right value on the left.
4146 if (pc_right == u_left) {
4147 qsort_swap(u_left, pc_left);
4148 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4150 qsort_rotate(pc_right, pc_left, u_left);
4151 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4156 /* No more scanning required on either side of partition,
4157 break out of loop and figure out next set of partitions
4163 /* The elements in the pivot chunk are now in the right place. They
4164 will never move or be compared again. All I have to do is decide
4165 what to do with the stuff to the left and right of the pivot
4168 Notes on the QSORT_ORDER_GUESS ifdef code:
4170 1. If I just built these partitions without swapping any (or
4171 very many) elements, there is a chance that the elements are
4172 already ordered properly (being properly ordered will
4173 certainly result in no swapping, but the converse can't be
4176 2. A (properly written) insertion sort will run faster on
4177 already ordered data than qsort will.
4179 3. Perhaps there is some way to make a good guess about
4180 switching to an insertion sort earlier than partition size 6
4181 (for instance - we could save the partition size on the stack
4182 and increase the size each time we find we didn't swap, thus
4183 switching to insertion sort earlier for partitions with a
4184 history of not swapping).
4186 4. Naturally, if I just switch right away, it will make
4187 artificial benchmarks with pure ascending (or descending)
4188 data look really good, but is that a good reason in general?
4192 #ifdef QSORT_ORDER_GUESS
4194 #if QSORT_ORDER_GUESS == 1
4195 qsort_break_even = (part_right - part_left) + 1;
4197 #if QSORT_ORDER_GUESS == 2
4198 qsort_break_even *= 2;
4200 #if QSORT_ORDER_GUESS == 3
4201 int prev_break = qsort_break_even;
4202 qsort_break_even *= qsort_break_even;
4203 if (qsort_break_even < prev_break) {
4204 qsort_break_even = (part_right - part_left) + 1;
4208 qsort_break_even = QSORT_BREAK_EVEN;
4212 if (part_left < pc_left) {
4213 /* There are elements on the left which need more processing.
4214 Check the right as well before deciding what to do.
4216 if (pc_right < part_right) {
4217 /* We have two partitions to be sorted. Stack the biggest one
4218 and process the smallest one on the next iteration. This
4219 minimizes the stack height by insuring that any additional
4220 stack entries must come from the smallest partition which
4221 (because it is smallest) will have the fewest
4222 opportunities to generate additional stack entries.
4224 if ((part_right - pc_right) > (pc_left - part_left)) {
4225 /* stack the right partition, process the left */
4226 partition_stack[next_stack_entry].left = pc_right + 1;
4227 partition_stack[next_stack_entry].right = part_right;
4228 #ifdef QSORT_ORDER_GUESS
4229 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4231 part_right = pc_left - 1;
4233 /* stack the left partition, process the right */
4234 partition_stack[next_stack_entry].left = part_left;
4235 partition_stack[next_stack_entry].right = pc_left - 1;
4236 #ifdef QSORT_ORDER_GUESS
4237 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4239 part_left = pc_right + 1;
4241 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4244 /* The elements on the left are the only remaining elements
4245 that need sorting, arrange for them to be processed as the
4248 part_right = pc_left - 1;
4250 } else if (pc_right < part_right) {
4251 /* There is only one chunk on the right to be sorted, make it
4252 the new partition and loop back around.
4254 part_left = pc_right + 1;
4256 /* This whole partition wound up in the pivot chunk, so
4257 we need to get a new partition off the stack.
4259 if (next_stack_entry == 0) {
4260 /* the stack is empty - we are done */
4264 part_left = partition_stack[next_stack_entry].left;
4265 part_right = partition_stack[next_stack_entry].right;
4266 #ifdef QSORT_ORDER_GUESS
4267 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4271 /* This partition is too small to fool with qsort complexity, just
4272 do an ordinary insertion sort to minimize overhead.
4275 /* Assume 1st element is in right place already, and start checking
4276 at 2nd element to see where it should be inserted.
4278 for (i = part_left + 1; i <= part_right; ++i) {
4280 /* Scan (backwards - just in case 'i' is already in right place)
4281 through the elements already sorted to see if the ith element
4282 belongs ahead of one of them.
4284 for (j = i - 1; j >= part_left; --j) {
4285 if (qsort_cmp(i, j) >= 0) {
4286 /* i belongs right after j
4293 /* Looks like we really need to move some things
4297 for (k = i - 1; k >= j; --k)
4298 array[k + 1] = array[k];
4303 /* That partition is now sorted, grab the next one, or get out
4304 of the loop if there aren't any more.
4307 if (next_stack_entry == 0) {
4308 /* the stack is empty - we are done */
4312 part_left = partition_stack[next_stack_entry].left;
4313 part_right = partition_stack[next_stack_entry].right;
4314 #ifdef QSORT_ORDER_GUESS
4315 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4320 /* Believe it or not, the array is sorted at this point! */
4332 sortcv(pTHXo_ SV *a, SV *b)
4335 I32 oldsaveix = PL_savestack_ix;
4336 I32 oldscopeix = PL_scopestack_ix;
4338 GvSV(PL_firstgv) = a;
4339 GvSV(PL_secondgv) = b;
4340 PL_stack_sp = PL_stack_base;
4343 if (PL_stack_sp != PL_stack_base + 1)
4344 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4345 if (!SvNIOKp(*PL_stack_sp))
4346 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4347 result = SvIV(*PL_stack_sp);
4348 while (PL_scopestack_ix > oldscopeix) {
4351 leave_scope(oldsaveix);
4356 sortcv_stacked(pTHXo_ SV *a, SV *b)
4359 I32 oldsaveix = PL_savestack_ix;
4360 I32 oldscopeix = PL_scopestack_ix;
4365 av = (AV*)PL_curpad[0];
4367 av = GvAV(PL_defgv);
4370 if (AvMAX(av) < 1) {
4371 SV** ary = AvALLOC(av);
4372 if (AvARRAY(av) != ary) {
4373 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4374 SvPVX(av) = (char*)ary;
4376 if (AvMAX(av) < 1) {
4379 SvPVX(av) = (char*)ary;
4386 PL_stack_sp = PL_stack_base;
4389 if (PL_stack_sp != PL_stack_base + 1)
4390 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4391 if (!SvNIOKp(*PL_stack_sp))
4392 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4393 result = SvIV(*PL_stack_sp);
4394 while (PL_scopestack_ix > oldscopeix) {
4397 leave_scope(oldsaveix);
4402 sortcv_xsub(pTHXo_ SV *a, SV *b)
4405 I32 oldsaveix = PL_savestack_ix;
4406 I32 oldscopeix = PL_scopestack_ix;
4408 CV *cv=(CV*)PL_sortcop;
4416 (void)(*CvXSUB(cv))(aTHXo_ cv);
4417 if (PL_stack_sp != PL_stack_base + 1)
4418 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4419 if (!SvNIOKp(*PL_stack_sp))
4420 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4421 result = SvIV(*PL_stack_sp);
4422 while (PL_scopestack_ix > oldscopeix) {
4425 leave_scope(oldsaveix);
4431 sv_ncmp(pTHXo_ SV *a, SV *b)
4435 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4439 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4443 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4445 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4447 if (PL_amagic_generation) { \
4448 if (SvAMAGIC(left)||SvAMAGIC(right))\
4449 *svp = amagic_call(left, \
4457 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4460 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4465 I32 i = SvIVX(tmpsv);
4475 return sv_ncmp(aTHXo_ a, b);
4479 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4482 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4487 I32 i = SvIVX(tmpsv);
4497 return sv_i_ncmp(aTHXo_ a, b);
4501 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4504 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4509 I32 i = SvIVX(tmpsv);
4519 return sv_cmp(str1, str2);
4523 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4526 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4531 I32 i = SvIVX(tmpsv);
4541 return sv_cmp_locale(str1, str2);
4545 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4547 SV *datasv = FILTER_DATA(idx);
4548 int filter_has_file = IoLINES(datasv);
4549 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4550 SV *filter_state = (SV *)IoTOP_GV(datasv);
4551 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4554 /* I was having segfault trouble under Linux 2.2.5 after a
4555 parse error occured. (Had to hack around it with a test
4556 for PL_error_count == 0.) Solaris doesn't segfault --
4557 not sure where the trouble is yet. XXX */
4559 if (filter_has_file) {
4560 len = FILTER_READ(idx+1, buf_sv, maxlen);
4563 if (filter_sub && len >= 0) {
4574 PUSHs(sv_2mortal(newSViv(maxlen)));
4576 PUSHs(filter_state);
4579 count = call_sv(filter_sub, G_SCALAR);
4595 IoLINES(datasv) = 0;
4596 if (filter_child_proc) {
4597 SvREFCNT_dec(filter_child_proc);
4598 IoFMT_GV(datasv) = Nullgv;
4601 SvREFCNT_dec(filter_state);
4602 IoTOP_GV(datasv) = Nullgv;
4605 SvREFCNT_dec(filter_sub);
4606 IoBOTTOM_GV(datasv) = Nullgv;
4608 filter_del(run_user_filter);
4617 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4619 return sv_cmp_locale(str1, str2);
4623 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4625 return sv_cmp(str1, str2);
4628 #endif /* PERL_OBJECT */