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 ;
1574 if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD)
1575 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1576 else if (old_warnings == pWARN_ALL)
1577 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1579 mask = newSVsv(old_warnings);
1580 PUSHs(sv_2mortal(mask));
1595 sv_reset(tmps, CopSTASH(PL_curcop));
1607 PL_curcop = (COP*)PL_op;
1608 TAINT_NOT; /* Each statement is presumed innocent */
1609 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1612 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1616 register PERL_CONTEXT *cx;
1617 I32 gimme = G_ARRAY;
1624 DIE(aTHX_ "No DB::DB routine defined");
1626 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1638 push_return(PL_op->op_next);
1639 PUSHBLOCK(cx, CXt_SUB, SP);
1642 (void)SvREFCNT_inc(cv);
1643 SAVEVPTR(PL_curpad);
1644 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1645 RETURNOP(CvSTART(cv));
1659 register PERL_CONTEXT *cx;
1660 I32 gimme = GIMME_V;
1662 U32 cxtype = CXt_LOOP;
1671 if (PL_op->op_flags & OPf_SPECIAL) {
1673 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1674 SAVEGENERICSV(*svp);
1678 #endif /* USE_THREADS */
1679 if (PL_op->op_targ) {
1680 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1683 iterdata = (void*)PL_op->op_targ;
1684 cxtype |= CXp_PADVAR;
1689 svp = &GvSV(gv); /* symbol table variable */
1690 SAVEGENERICSV(*svp);
1693 iterdata = (void*)gv;
1699 PUSHBLOCK(cx, cxtype, SP);
1701 PUSHLOOP(cx, iterdata, MARK);
1703 PUSHLOOP(cx, svp, MARK);
1705 if (PL_op->op_flags & OPf_STACKED) {
1706 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1707 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1709 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1710 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1711 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1712 looks_like_number((SV*)cx->blk_loop.iterary) &&
1713 *SvPVX(cx->blk_loop.iterary) != '0'))
1715 if (SvNV(sv) < IV_MIN ||
1716 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1717 DIE(aTHX_ "Range iterator outside integer range");
1718 cx->blk_loop.iterix = SvIV(sv);
1719 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1722 cx->blk_loop.iterlval = newSVsv(sv);
1726 cx->blk_loop.iterary = PL_curstack;
1727 AvFILLp(PL_curstack) = SP - PL_stack_base;
1728 cx->blk_loop.iterix = MARK - PL_stack_base;
1737 register PERL_CONTEXT *cx;
1738 I32 gimme = GIMME_V;
1744 PUSHBLOCK(cx, CXt_LOOP, SP);
1745 PUSHLOOP(cx, 0, SP);
1753 register PERL_CONTEXT *cx;
1761 newsp = PL_stack_base + cx->blk_loop.resetsp;
1764 if (gimme == G_VOID)
1766 else if (gimme == G_SCALAR) {
1768 *++newsp = sv_mortalcopy(*SP);
1770 *++newsp = &PL_sv_undef;
1774 *++newsp = sv_mortalcopy(*++mark);
1775 TAINT_NOT; /* Each item is independent */
1781 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1782 PL_curpm = newpm; /* ... and pop $1 et al */
1794 register PERL_CONTEXT *cx;
1795 bool popsub2 = FALSE;
1796 bool clear_errsv = FALSE;
1803 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1804 if (cxstack_ix == PL_sortcxix
1805 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1807 if (cxstack_ix > PL_sortcxix)
1808 dounwind(PL_sortcxix);
1809 AvARRAY(PL_curstack)[1] = *SP;
1810 PL_stack_sp = PL_stack_base + 1;
1815 cxix = dopoptosub(cxstack_ix);
1817 DIE(aTHX_ "Can't return outside a subroutine");
1818 if (cxix < cxstack_ix)
1822 switch (CxTYPE(cx)) {
1827 if (!(PL_in_eval & EVAL_KEEPERR))
1832 if (AvFILLp(PL_comppad_name) >= 0)
1835 if (optype == OP_REQUIRE &&
1836 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1838 /* Unassume the success we assumed earlier. */
1839 SV *nsv = cx->blk_eval.old_namesv;
1840 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1841 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1848 DIE(aTHX_ "panic: return");
1852 if (gimme == G_SCALAR) {
1855 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1857 *++newsp = SvREFCNT_inc(*SP);
1862 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1864 *++newsp = sv_mortalcopy(sv);
1869 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1872 *++newsp = sv_mortalcopy(*SP);
1875 *++newsp = &PL_sv_undef;
1877 else if (gimme == G_ARRAY) {
1878 while (++MARK <= SP) {
1879 *++newsp = (popsub2 && SvTEMP(*MARK))
1880 ? *MARK : sv_mortalcopy(*MARK);
1881 TAINT_NOT; /* Each item is independent */
1884 PL_stack_sp = newsp;
1886 /* Stack values are safe: */
1888 POPSUB(cx,sv); /* release CV and @_ ... */
1892 PL_curpm = newpm; /* ... and pop $1 et al */
1898 return pop_return();
1905 register PERL_CONTEXT *cx;
1915 if (PL_op->op_flags & OPf_SPECIAL) {
1916 cxix = dopoptoloop(cxstack_ix);
1918 DIE(aTHX_ "Can't \"last\" outside a loop block");
1921 cxix = dopoptolabel(cPVOP->op_pv);
1923 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1925 if (cxix < cxstack_ix)
1930 switch (CxTYPE(cx)) {
1933 newsp = PL_stack_base + cx->blk_loop.resetsp;
1934 nextop = cx->blk_loop.last_op->op_next;
1938 nextop = pop_return();
1942 nextop = pop_return();
1946 nextop = pop_return();
1949 DIE(aTHX_ "panic: last");
1953 if (gimme == G_SCALAR) {
1955 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1956 ? *SP : sv_mortalcopy(*SP);
1958 *++newsp = &PL_sv_undef;
1960 else if (gimme == G_ARRAY) {
1961 while (++MARK <= SP) {
1962 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1963 ? *MARK : sv_mortalcopy(*MARK);
1964 TAINT_NOT; /* Each item is independent */
1970 /* Stack values are safe: */
1973 POPLOOP(cx); /* release loop vars ... */
1977 POPSUB(cx,sv); /* release CV and @_ ... */
1980 PL_curpm = newpm; /* ... and pop $1 et al */
1990 register PERL_CONTEXT *cx;
1993 if (PL_op->op_flags & OPf_SPECIAL) {
1994 cxix = dopoptoloop(cxstack_ix);
1996 DIE(aTHX_ "Can't \"next\" outside a loop block");
1999 cxix = dopoptolabel(cPVOP->op_pv);
2001 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2003 if (cxix < cxstack_ix)
2006 /* clear off anything above the scope we're re-entering, but
2007 * save the rest until after a possible continue block */
2008 inner = PL_scopestack_ix;
2010 if (PL_scopestack_ix < inner)
2011 leave_scope(PL_scopestack[PL_scopestack_ix]);
2012 return cx->blk_loop.next_op;
2018 register PERL_CONTEXT *cx;
2021 if (PL_op->op_flags & OPf_SPECIAL) {
2022 cxix = dopoptoloop(cxstack_ix);
2024 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2027 cxix = dopoptolabel(cPVOP->op_pv);
2029 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2031 if (cxix < cxstack_ix)
2035 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2036 LEAVE_SCOPE(oldsave);
2037 return cx->blk_loop.redo_op;
2041 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2045 static char too_deep[] = "Target of goto is too deeply nested";
2048 Perl_croak(aTHX_ too_deep);
2049 if (o->op_type == OP_LEAVE ||
2050 o->op_type == OP_SCOPE ||
2051 o->op_type == OP_LEAVELOOP ||
2052 o->op_type == OP_LEAVETRY)
2054 *ops++ = cUNOPo->op_first;
2056 Perl_croak(aTHX_ too_deep);
2059 if (o->op_flags & OPf_KIDS) {
2061 /* First try all the kids at this level, since that's likeliest. */
2062 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2063 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2064 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2067 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2068 if (kid == PL_lastgotoprobe)
2070 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2072 (ops[-1]->op_type != OP_NEXTSTATE &&
2073 ops[-1]->op_type != OP_DBSTATE)))
2075 if ((o = dofindlabel(kid, label, ops, oplimit)))
2094 register PERL_CONTEXT *cx;
2095 #define GOTO_DEPTH 64
2096 OP *enterops[GOTO_DEPTH];
2098 int do_dump = (PL_op->op_type == OP_DUMP);
2099 static char must_have_label[] = "goto must have label";
2102 if (PL_op->op_flags & OPf_STACKED) {
2106 /* This egregious kludge implements goto &subroutine */
2107 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2109 register PERL_CONTEXT *cx;
2110 CV* cv = (CV*)SvRV(sv);
2116 if (!CvROOT(cv) && !CvXSUB(cv)) {
2121 /* autoloaded stub? */
2122 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2124 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2125 GvNAMELEN(gv), FALSE);
2126 if (autogv && (cv = GvCV(autogv)))
2128 tmpstr = sv_newmortal();
2129 gv_efullname3(tmpstr, gv, Nullch);
2130 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2132 DIE(aTHX_ "Goto undefined subroutine");
2135 /* First do some returnish stuff. */
2136 cxix = dopoptosub(cxstack_ix);
2138 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2139 if (cxix < cxstack_ix)
2142 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2143 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2145 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2146 /* put @_ back onto stack */
2147 AV* av = cx->blk_sub.argarray;
2149 items = AvFILLp(av) + 1;
2151 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2152 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2153 PL_stack_sp += items;
2155 SvREFCNT_dec(GvAV(PL_defgv));
2156 GvAV(PL_defgv) = cx->blk_sub.savearray;
2157 #endif /* USE_THREADS */
2158 /* abandon @_ if it got reified */
2160 (void)sv_2mortal((SV*)av); /* delay until return */
2162 av_extend(av, items-1);
2163 AvFLAGS(av) = AVf_REIFY;
2164 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2167 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2170 av = (AV*)PL_curpad[0];
2172 av = GvAV(PL_defgv);
2174 items = AvFILLp(av) + 1;
2176 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2177 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2178 PL_stack_sp += items;
2180 if (CxTYPE(cx) == CXt_SUB &&
2181 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2182 SvREFCNT_dec(cx->blk_sub.cv);
2183 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2184 LEAVE_SCOPE(oldsave);
2186 /* Now do some callish stuff. */
2189 #ifdef PERL_XSUB_OLDSTYLE
2190 if (CvOLDSTYLE(cv)) {
2191 I32 (*fp3)(int,int,int);
2196 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2197 items = (*fp3)(CvXSUBANY(cv).any_i32,
2198 mark - PL_stack_base + 1,
2200 SP = PL_stack_base + items;
2203 #endif /* PERL_XSUB_OLDSTYLE */
2208 PL_stack_sp--; /* There is no cv arg. */
2209 /* Push a mark for the start of arglist */
2211 (void)(*CvXSUB(cv))(aTHXo_ cv);
2212 /* Pop the current context like a decent sub should */
2213 POPBLOCK(cx, PL_curpm);
2214 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2217 return pop_return();
2220 AV* padlist = CvPADLIST(cv);
2221 SV** svp = AvARRAY(padlist);
2222 if (CxTYPE(cx) == CXt_EVAL) {
2223 PL_in_eval = cx->blk_eval.old_in_eval;
2224 PL_eval_root = cx->blk_eval.old_eval_root;
2225 cx->cx_type = CXt_SUB;
2226 cx->blk_sub.hasargs = 0;
2228 cx->blk_sub.cv = cv;
2229 cx->blk_sub.olddepth = CvDEPTH(cv);
2231 if (CvDEPTH(cv) < 2)
2232 (void)SvREFCNT_inc(cv);
2233 else { /* save temporaries on recursion? */
2234 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2235 sub_crush_depth(cv);
2236 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2237 AV *newpad = newAV();
2238 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2239 I32 ix = AvFILLp((AV*)svp[1]);
2240 I32 names_fill = AvFILLp((AV*)svp[0]);
2241 svp = AvARRAY(svp[0]);
2242 for ( ;ix > 0; ix--) {
2243 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2244 char *name = SvPVX(svp[ix]);
2245 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2248 /* outer lexical or anon code */
2249 av_store(newpad, ix,
2250 SvREFCNT_inc(oldpad[ix]) );
2252 else { /* our own lexical */
2254 av_store(newpad, ix, sv = (SV*)newAV());
2255 else if (*name == '%')
2256 av_store(newpad, ix, sv = (SV*)newHV());
2258 av_store(newpad, ix, sv = NEWSV(0,0));
2262 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2263 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2266 av_store(newpad, ix, sv = NEWSV(0,0));
2270 if (cx->blk_sub.hasargs) {
2273 av_store(newpad, 0, (SV*)av);
2274 AvFLAGS(av) = AVf_REIFY;
2276 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2277 AvFILLp(padlist) = CvDEPTH(cv);
2278 svp = AvARRAY(padlist);
2282 if (!cx->blk_sub.hasargs) {
2283 AV* av = (AV*)PL_curpad[0];
2285 items = AvFILLp(av) + 1;
2287 /* Mark is at the end of the stack. */
2289 Copy(AvARRAY(av), SP + 1, items, SV*);
2294 #endif /* USE_THREADS */
2295 SAVEVPTR(PL_curpad);
2296 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2298 if (cx->blk_sub.hasargs)
2299 #endif /* USE_THREADS */
2301 AV* av = (AV*)PL_curpad[0];
2305 cx->blk_sub.savearray = GvAV(PL_defgv);
2306 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2307 #endif /* USE_THREADS */
2308 cx->blk_sub.argarray = av;
2311 if (items >= AvMAX(av) + 1) {
2313 if (AvARRAY(av) != ary) {
2314 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2315 SvPVX(av) = (char*)ary;
2317 if (items >= AvMAX(av) + 1) {
2318 AvMAX(av) = items - 1;
2319 Renew(ary,items+1,SV*);
2321 SvPVX(av) = (char*)ary;
2324 Copy(mark,AvARRAY(av),items,SV*);
2325 AvFILLp(av) = items - 1;
2326 assert(!AvREAL(av));
2333 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2335 * We do not care about using sv to call CV;
2336 * it's for informational purposes only.
2338 SV *sv = GvSV(PL_DBsub);
2341 if (PERLDB_SUB_NN) {
2342 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2345 gv_efullname3(sv, CvGV(cv), Nullch);
2348 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2349 PUSHMARK( PL_stack_sp );
2350 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2354 RETURNOP(CvSTART(cv));
2358 label = SvPV(sv,n_a);
2359 if (!(do_dump || *label))
2360 DIE(aTHX_ must_have_label);
2363 else if (PL_op->op_flags & OPf_SPECIAL) {
2365 DIE(aTHX_ must_have_label);
2368 label = cPVOP->op_pv;
2370 if (label && *label) {
2375 PL_lastgotoprobe = 0;
2377 for (ix = cxstack_ix; ix >= 0; ix--) {
2379 switch (CxTYPE(cx)) {
2381 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2384 gotoprobe = cx->blk_oldcop->op_sibling;
2390 gotoprobe = cx->blk_oldcop->op_sibling;
2392 gotoprobe = PL_main_root;
2395 if (CvDEPTH(cx->blk_sub.cv)) {
2396 gotoprobe = CvROOT(cx->blk_sub.cv);
2402 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2405 DIE(aTHX_ "panic: goto");
2406 gotoprobe = PL_main_root;
2410 retop = dofindlabel(gotoprobe, label,
2411 enterops, enterops + GOTO_DEPTH);
2415 PL_lastgotoprobe = gotoprobe;
2418 DIE(aTHX_ "Can't find label %s", label);
2420 /* pop unwanted frames */
2422 if (ix < cxstack_ix) {
2429 oldsave = PL_scopestack[PL_scopestack_ix];
2430 LEAVE_SCOPE(oldsave);
2433 /* push wanted frames */
2435 if (*enterops && enterops[1]) {
2437 for (ix = 1; enterops[ix]; ix++) {
2438 PL_op = enterops[ix];
2439 /* Eventually we may want to stack the needed arguments
2440 * for each op. For now, we punt on the hard ones. */
2441 if (PL_op->op_type == OP_ENTERITER)
2442 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2443 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2451 if (!retop) retop = PL_main_start;
2453 PL_restartop = retop;
2454 PL_do_undump = TRUE;
2458 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2459 PL_do_undump = FALSE;
2475 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2479 PL_exit_flags |= PERL_EXIT_EXPECTED;
2481 PUSHs(&PL_sv_undef);
2489 NV value = SvNVx(GvSV(cCOP->cop_gv));
2490 register I32 match = I_32(value);
2493 if (((NV)match) > value)
2494 --match; /* was fractional--truncate other way */
2496 match -= cCOP->uop.scop.scop_offset;
2499 else if (match > cCOP->uop.scop.scop_max)
2500 match = cCOP->uop.scop.scop_max;
2501 PL_op = cCOP->uop.scop.scop_next[match];
2511 PL_op = PL_op->op_next; /* can't assume anything */
2514 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2515 match -= cCOP->uop.scop.scop_offset;
2518 else if (match > cCOP->uop.scop.scop_max)
2519 match = cCOP->uop.scop.scop_max;
2520 PL_op = cCOP->uop.scop.scop_next[match];
2529 S_save_lines(pTHX_ AV *array, SV *sv)
2531 register char *s = SvPVX(sv);
2532 register char *send = SvPVX(sv) + SvCUR(sv);
2534 register I32 line = 1;
2536 while (s && s < send) {
2537 SV *tmpstr = NEWSV(85,0);
2539 sv_upgrade(tmpstr, SVt_PVMG);
2540 t = strchr(s, '\n');
2546 sv_setpvn(tmpstr, s, t - s);
2547 av_store(array, line++, tmpstr);
2552 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2554 S_docatch_body(pTHX_ va_list args)
2556 return docatch_body();
2561 S_docatch_body(pTHX)
2568 S_docatch(pTHX_ OP *o)
2573 volatile PERL_SI *cursi = PL_curstackinfo;
2577 assert(CATCH_GET == TRUE);
2580 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2582 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2588 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2594 if (PL_restartop && cursi == PL_curstackinfo) {
2595 PL_op = PL_restartop;
2612 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2613 /* sv Text to convert to OP tree. */
2614 /* startop op_free() this to undo. */
2615 /* code Short string id of the caller. */
2617 dSP; /* Make POPBLOCK work. */
2620 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2624 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2625 char *tmpbuf = tbuf;
2631 /* switch to eval mode */
2633 if (PL_curcop == &PL_compiling) {
2634 SAVECOPSTASH(&PL_compiling);
2635 CopSTASH_set(&PL_compiling, PL_curstash);
2637 SAVECOPFILE(&PL_compiling);
2638 SAVECOPLINE(&PL_compiling);
2639 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2640 SV *sv = sv_newmortal();
2641 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2642 code, (unsigned long)++PL_evalseq,
2643 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2647 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2648 CopFILE_set(&PL_compiling, tmpbuf+2);
2649 CopLINE_set(&PL_compiling, 1);
2650 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2651 deleting the eval's FILEGV from the stash before gv_check() runs
2652 (i.e. before run-time proper). To work around the coredump that
2653 ensues, we always turn GvMULTI_on for any globals that were
2654 introduced within evals. See force_ident(). GSAR 96-10-12 */
2655 safestr = savepv(tmpbuf);
2656 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2658 #ifdef OP_IN_REGISTER
2666 PL_op->op_type = OP_ENTEREVAL;
2667 PL_op->op_flags = 0; /* Avoid uninit warning. */
2668 PUSHBLOCK(cx, CXt_EVAL, SP);
2669 PUSHEVAL(cx, 0, Nullgv);
2670 rop = doeval(G_SCALAR, startop);
2671 POPBLOCK(cx,PL_curpm);
2674 (*startop)->op_type = OP_NULL;
2675 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2677 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2679 if (PL_curcop == &PL_compiling)
2680 PL_compiling.op_private = PL_hints;
2681 #ifdef OP_IN_REGISTER
2687 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2689 S_doeval(pTHX_ int gimme, OP** startop)
2697 PL_in_eval = EVAL_INEVAL;
2701 /* set up a scratch pad */
2704 SAVEVPTR(PL_curpad);
2705 SAVESPTR(PL_comppad);
2706 SAVESPTR(PL_comppad_name);
2707 SAVEI32(PL_comppad_name_fill);
2708 SAVEI32(PL_min_intro_pending);
2709 SAVEI32(PL_max_intro_pending);
2712 for (i = cxstack_ix - 1; i >= 0; i--) {
2713 PERL_CONTEXT *cx = &cxstack[i];
2714 if (CxTYPE(cx) == CXt_EVAL)
2716 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2717 caller = cx->blk_sub.cv;
2722 SAVESPTR(PL_compcv);
2723 PL_compcv = (CV*)NEWSV(1104,0);
2724 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2725 CvEVAL_on(PL_compcv);
2727 CvOWNER(PL_compcv) = 0;
2728 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2729 MUTEX_INIT(CvMUTEXP(PL_compcv));
2730 #endif /* USE_THREADS */
2732 PL_comppad = newAV();
2733 av_push(PL_comppad, Nullsv);
2734 PL_curpad = AvARRAY(PL_comppad);
2735 PL_comppad_name = newAV();
2736 PL_comppad_name_fill = 0;
2737 PL_min_intro_pending = 0;
2740 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2741 PL_curpad[0] = (SV*)newAV();
2742 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2743 #endif /* USE_THREADS */
2745 comppadlist = newAV();
2746 AvREAL_off(comppadlist);
2747 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2748 av_store(comppadlist, 1, (SV*)PL_comppad);
2749 CvPADLIST(PL_compcv) = comppadlist;
2752 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2754 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2757 SAVEFREESV(PL_compcv);
2759 /* make sure we compile in the right package */
2761 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2762 SAVESPTR(PL_curstash);
2763 PL_curstash = CopSTASH(PL_curcop);
2765 SAVESPTR(PL_beginav);
2766 PL_beginav = newAV();
2767 SAVEFREESV(PL_beginav);
2768 SAVEI32(PL_error_count);
2770 /* try to compile it */
2772 PL_eval_root = Nullop;
2774 PL_curcop = &PL_compiling;
2775 PL_curcop->cop_arybase = 0;
2776 SvREFCNT_dec(PL_rs);
2777 PL_rs = newSVpvn("\n", 1);
2778 if (saveop && saveop->op_flags & OPf_SPECIAL)
2779 PL_in_eval |= EVAL_KEEPERR;
2782 if (yyparse() || PL_error_count || !PL_eval_root) {
2786 I32 optype = 0; /* Might be reset by POPEVAL. */
2791 op_free(PL_eval_root);
2792 PL_eval_root = Nullop;
2794 SP = PL_stack_base + POPMARK; /* pop original mark */
2796 POPBLOCK(cx,PL_curpm);
2802 if (optype == OP_REQUIRE) {
2803 char* msg = SvPVx(ERRSV, n_a);
2804 DIE(aTHX_ "%sCompilation failed in require",
2805 *msg ? msg : "Unknown error\n");
2808 char* msg = SvPVx(ERRSV, n_a);
2810 POPBLOCK(cx,PL_curpm);
2812 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2813 (*msg ? msg : "Unknown error\n"));
2815 SvREFCNT_dec(PL_rs);
2816 PL_rs = SvREFCNT_inc(PL_nrs);
2818 MUTEX_LOCK(&PL_eval_mutex);
2820 COND_SIGNAL(&PL_eval_cond);
2821 MUTEX_UNLOCK(&PL_eval_mutex);
2822 #endif /* USE_THREADS */
2825 SvREFCNT_dec(PL_rs);
2826 PL_rs = SvREFCNT_inc(PL_nrs);
2827 CopLINE_set(&PL_compiling, 0);
2829 *startop = PL_eval_root;
2830 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2831 CvOUTSIDE(PL_compcv) = Nullcv;
2833 SAVEFREEOP(PL_eval_root);
2835 scalarvoid(PL_eval_root);
2836 else if (gimme & G_ARRAY)
2839 scalar(PL_eval_root);
2841 DEBUG_x(dump_eval());
2843 /* Register with debugger: */
2844 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2845 CV *cv = get_cv("DB::postponed", FALSE);
2849 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2851 call_sv((SV*)cv, G_DISCARD);
2855 /* compiled okay, so do it */
2857 CvDEPTH(PL_compcv) = 1;
2858 SP = PL_stack_base + POPMARK; /* pop original mark */
2859 PL_op = saveop; /* The caller may need it. */
2861 MUTEX_LOCK(&PL_eval_mutex);
2863 COND_SIGNAL(&PL_eval_cond);
2864 MUTEX_UNLOCK(&PL_eval_mutex);
2865 #endif /* USE_THREADS */
2867 RETURNOP(PL_eval_start);
2871 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2873 STRLEN namelen = strlen(name);
2876 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2877 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2878 char *pmc = SvPV_nolen(pmcsv);
2881 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2882 fp = PerlIO_open(name, mode);
2885 if (PerlLIO_stat(name, &pmstat) < 0 ||
2886 pmstat.st_mtime < pmcstat.st_mtime)
2888 fp = PerlIO_open(pmc, mode);
2891 fp = PerlIO_open(name, mode);
2894 SvREFCNT_dec(pmcsv);
2897 fp = PerlIO_open(name, mode);
2905 register PERL_CONTEXT *cx;
2910 SV *namesv = Nullsv;
2912 I32 gimme = G_SCALAR;
2913 PerlIO *tryrsfp = 0;
2915 int filter_has_file = 0;
2916 GV *filter_child_proc = 0;
2917 SV *filter_state = 0;
2922 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2923 UV rev = 0, ver = 0, sver = 0;
2925 U8 *s = (U8*)SvPVX(sv);
2926 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2928 rev = utf8_to_uv(s, &len);
2931 ver = utf8_to_uv(s, &len);
2934 sver = utf8_to_uv(s, &len);
2937 if (PERL_REVISION < rev
2938 || (PERL_REVISION == rev
2939 && (PERL_VERSION < ver
2940 || (PERL_VERSION == ver
2941 && PERL_SUBVERSION < sver))))
2943 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2944 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2945 PERL_VERSION, PERL_SUBVERSION);
2949 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2950 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2951 + ((NV)PERL_SUBVERSION/(NV)1000000)
2952 + 0.00000099 < SvNV(sv))
2956 NV nver = (nrev - rev) * 1000;
2957 UV ver = (UV)(nver + 0.0009);
2958 NV nsver = (nver - ver) * 1000;
2959 UV sver = (UV)(nsver + 0.0009);
2961 /* help out with the "use 5.6" confusion */
2962 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2963 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2964 "this is only v%d.%d.%d, stopped"
2965 " (did you mean v%"UVuf".%"UVuf".0?)",
2966 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2967 PERL_SUBVERSION, rev, ver/100);
2970 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2971 "this is only v%d.%d.%d, stopped",
2972 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2979 name = SvPV(sv, len);
2980 if (!(name && len > 0 && *name))
2981 DIE(aTHX_ "Null filename used");
2982 TAINT_PROPER("require");
2983 if (PL_op->op_type == OP_REQUIRE &&
2984 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2985 *svp != &PL_sv_undef)
2988 /* prepare to compile file */
2990 if (PERL_FILE_IS_ABSOLUTE(name)
2991 || (*name == '.' && (name[1] == '/' ||
2992 (name[1] == '.' && name[2] == '/'))))
2995 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2998 AV *ar = GvAVn(PL_incgv);
3002 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3005 namesv = NEWSV(806, 0);
3006 for (i = 0; i <= AvFILL(ar); i++) {
3007 SV *dirsv = *av_fetch(ar, i, TRUE);
3013 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3014 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3017 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3018 PTR2UV(SvANY(loader)), name);
3019 tryname = SvPVX(namesv);
3030 count = call_sv(loader, G_ARRAY);
3040 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3044 if (SvTYPE(arg) == SVt_PVGV) {
3045 IO *io = GvIO((GV *)arg);
3050 tryrsfp = IoIFP(io);
3051 if (IoTYPE(io) == '|') {
3052 /* reading from a child process doesn't
3053 nest -- when returning from reading
3054 the inner module, the outer one is
3055 unreadable (closed?) I've tried to
3056 save the gv to manage the lifespan of
3057 the pipe, but this didn't help. XXX */
3058 filter_child_proc = (GV *)arg;
3059 (void)SvREFCNT_inc(filter_child_proc);
3062 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3063 PerlIO_close(IoOFP(io));
3075 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3077 (void)SvREFCNT_inc(filter_sub);
3080 filter_state = SP[i];
3081 (void)SvREFCNT_inc(filter_state);
3085 tryrsfp = PerlIO_open("/dev/null",
3099 filter_has_file = 0;
3100 if (filter_child_proc) {
3101 SvREFCNT_dec(filter_child_proc);
3102 filter_child_proc = 0;
3105 SvREFCNT_dec(filter_state);
3109 SvREFCNT_dec(filter_sub);
3114 char *dir = SvPVx(dirsv, n_a);
3117 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3119 sv_setpv(namesv, unixdir);
3120 sv_catpv(namesv, unixname);
3122 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3124 TAINT_PROPER("require");
3125 tryname = SvPVX(namesv);
3126 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3128 if (tryname[0] == '.' && tryname[1] == '/')
3136 SAVECOPFILE(&PL_compiling);
3137 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3138 SvREFCNT_dec(namesv);
3140 if (PL_op->op_type == OP_REQUIRE) {
3141 char *msgstr = name;
3142 if (namesv) { /* did we lookup @INC? */
3143 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3144 SV *dirmsgsv = NEWSV(0, 0);
3145 AV *ar = GvAVn(PL_incgv);
3147 sv_catpvn(msg, " in @INC", 8);
3148 if (instr(SvPVX(msg), ".h "))
3149 sv_catpv(msg, " (change .h to .ph maybe?)");
3150 if (instr(SvPVX(msg), ".ph "))
3151 sv_catpv(msg, " (did you run h2ph?)");
3152 sv_catpv(msg, " (@INC contains:");
3153 for (i = 0; i <= AvFILL(ar); i++) {
3154 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3155 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3156 sv_catsv(msg, dirmsgsv);
3158 sv_catpvn(msg, ")", 1);
3159 SvREFCNT_dec(dirmsgsv);
3160 msgstr = SvPV_nolen(msg);
3162 DIE(aTHX_ "Can't locate %s", msgstr);
3168 SETERRNO(0, SS$_NORMAL);
3170 /* Assume success here to prevent recursive requirement. */
3171 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3172 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3176 lex_start(sv_2mortal(newSVpvn("",0)));
3177 SAVEGENERICSV(PL_rsfp_filters);
3178 PL_rsfp_filters = Nullav;
3183 SAVESPTR(PL_compiling.cop_warnings);
3184 if (PL_dowarn & G_WARN_ALL_ON)
3185 PL_compiling.cop_warnings = pWARN_ALL ;
3186 else if (PL_dowarn & G_WARN_ALL_OFF)
3187 PL_compiling.cop_warnings = pWARN_NONE ;
3189 PL_compiling.cop_warnings = pWARN_STD ;
3191 if (filter_sub || filter_child_proc) {
3192 SV *datasv = filter_add(run_user_filter, Nullsv);
3193 IoLINES(datasv) = filter_has_file;
3194 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3195 IoTOP_GV(datasv) = (GV *)filter_state;
3196 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3199 /* switch to eval mode */
3200 push_return(PL_op->op_next);
3201 PUSHBLOCK(cx, CXt_EVAL, SP);
3202 PUSHEVAL(cx, name, Nullgv);
3204 SAVECOPLINE(&PL_compiling);
3205 CopLINE_set(&PL_compiling, 0);
3209 MUTEX_LOCK(&PL_eval_mutex);
3210 if (PL_eval_owner && PL_eval_owner != thr)
3211 while (PL_eval_owner)
3212 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3213 PL_eval_owner = thr;
3214 MUTEX_UNLOCK(&PL_eval_mutex);
3215 #endif /* USE_THREADS */
3216 return DOCATCH(doeval(G_SCALAR, NULL));
3221 return pp_require();
3227 register PERL_CONTEXT *cx;
3229 I32 gimme = GIMME_V, was = PL_sub_generation;
3230 char tbuf[TYPE_DIGITS(long) + 12];
3231 char *tmpbuf = tbuf;
3236 if (!SvPV(sv,len) || !len)
3238 TAINT_PROPER("eval");
3244 /* switch to eval mode */
3246 SAVECOPFILE(&PL_compiling);
3247 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3248 SV *sv = sv_newmortal();
3249 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3250 (unsigned long)++PL_evalseq,
3251 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3255 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3256 CopFILE_set(&PL_compiling, tmpbuf+2);
3257 CopLINE_set(&PL_compiling, 1);
3258 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3259 deleting the eval's FILEGV from the stash before gv_check() runs
3260 (i.e. before run-time proper). To work around the coredump that
3261 ensues, we always turn GvMULTI_on for any globals that were
3262 introduced within evals. See force_ident(). GSAR 96-10-12 */
3263 safestr = savepv(tmpbuf);
3264 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3266 PL_hints = PL_op->op_targ;
3267 SAVESPTR(PL_compiling.cop_warnings);
3268 if (specialWARN(PL_curcop->cop_warnings))
3269 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3271 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3272 SAVEFREESV(PL_compiling.cop_warnings);
3275 push_return(PL_op->op_next);
3276 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3277 PUSHEVAL(cx, 0, Nullgv);
3279 /* prepare to compile string */
3281 if (PERLDB_LINE && PL_curstash != PL_debstash)
3282 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3285 MUTEX_LOCK(&PL_eval_mutex);
3286 if (PL_eval_owner && PL_eval_owner != thr)
3287 while (PL_eval_owner)
3288 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3289 PL_eval_owner = thr;
3290 MUTEX_UNLOCK(&PL_eval_mutex);
3291 #endif /* USE_THREADS */
3292 ret = doeval(gimme, NULL);
3293 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3294 && ret != PL_op->op_next) { /* Successive compilation. */
3295 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3297 return DOCATCH(ret);
3307 register PERL_CONTEXT *cx;
3309 U8 save_flags = PL_op -> op_flags;
3314 retop = pop_return();
3317 if (gimme == G_VOID)
3319 else if (gimme == G_SCALAR) {
3322 if (SvFLAGS(TOPs) & SVs_TEMP)
3325 *MARK = sv_mortalcopy(TOPs);
3329 *MARK = &PL_sv_undef;
3334 /* in case LEAVE wipes old return values */
3335 for (mark = newsp + 1; mark <= SP; mark++) {
3336 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3337 *mark = sv_mortalcopy(*mark);
3338 TAINT_NOT; /* Each item is independent */
3342 PL_curpm = newpm; /* Don't pop $1 et al till now */
3344 if (AvFILLp(PL_comppad_name) >= 0)
3348 assert(CvDEPTH(PL_compcv) == 1);
3350 CvDEPTH(PL_compcv) = 0;
3353 if (optype == OP_REQUIRE &&
3354 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3356 /* Unassume the success we assumed earlier. */
3357 SV *nsv = cx->blk_eval.old_namesv;
3358 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3359 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3360 /* die_where() did LEAVE, or we won't be here */
3364 if (!(save_flags & OPf_SPECIAL))
3374 register PERL_CONTEXT *cx;
3375 I32 gimme = GIMME_V;
3380 push_return(cLOGOP->op_other->op_next);
3381 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3383 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3385 PL_in_eval = EVAL_INEVAL;
3388 return DOCATCH(PL_op->op_next);
3398 register PERL_CONTEXT *cx;
3406 if (gimme == G_VOID)
3408 else if (gimme == G_SCALAR) {
3411 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3414 *MARK = sv_mortalcopy(TOPs);
3418 *MARK = &PL_sv_undef;
3423 /* in case LEAVE wipes old return values */
3424 for (mark = newsp + 1; mark <= SP; mark++) {
3425 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3426 *mark = sv_mortalcopy(*mark);
3427 TAINT_NOT; /* Each item is independent */
3431 PL_curpm = newpm; /* Don't pop $1 et al till now */
3439 S_doparseform(pTHX_ SV *sv)
3442 register char *s = SvPV_force(sv, len);
3443 register char *send = s + len;
3444 register char *base;
3445 register I32 skipspaces = 0;
3448 bool postspace = FALSE;
3456 Perl_croak(aTHX_ "Null picture in formline");
3458 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3463 *fpc++ = FF_LINEMARK;
3464 noblank = repeat = FALSE;
3482 case ' ': case '\t':
3493 *fpc++ = FF_LITERAL;
3501 *fpc++ = skipspaces;
3505 *fpc++ = FF_NEWLINE;
3509 arg = fpc - linepc + 1;
3516 *fpc++ = FF_LINEMARK;
3517 noblank = repeat = FALSE;
3526 ischop = s[-1] == '^';
3532 arg = (s - base) - 1;
3534 *fpc++ = FF_LITERAL;
3543 *fpc++ = FF_LINEGLOB;
3545 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3546 arg = ischop ? 512 : 0;
3556 arg |= 256 + (s - f);
3558 *fpc++ = s - base; /* fieldsize for FETCH */
3559 *fpc++ = FF_DECIMAL;
3564 bool ismore = FALSE;
3567 while (*++s == '>') ;
3568 prespace = FF_SPACE;
3570 else if (*s == '|') {
3571 while (*++s == '|') ;
3572 prespace = FF_HALFSPACE;
3577 while (*++s == '<') ;
3580 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3584 *fpc++ = s - base; /* fieldsize for FETCH */
3586 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3604 { /* need to jump to the next word */
3606 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3607 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3608 s = SvPVX(sv) + SvCUR(sv) + z;
3610 Copy(fops, s, arg, U16);
3612 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3617 * The rest of this file was derived from source code contributed
3620 * NOTE: this code was derived from Tom Horsley's qsort replacement
3621 * and should not be confused with the original code.
3624 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3626 Permission granted to distribute under the same terms as perl which are
3629 This program is free software; you can redistribute it and/or modify
3630 it under the terms of either:
3632 a) the GNU General Public License as published by the Free
3633 Software Foundation; either version 1, or (at your option) any
3636 b) the "Artistic License" which comes with this Kit.
3638 Details on the perl license can be found in the perl source code which
3639 may be located via the www.perl.com web page.
3641 This is the most wonderfulest possible qsort I can come up with (and
3642 still be mostly portable) My (limited) tests indicate it consistently
3643 does about 20% fewer calls to compare than does the qsort in the Visual
3644 C++ library, other vendors may vary.
3646 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3647 others I invented myself (or more likely re-invented since they seemed
3648 pretty obvious once I watched the algorithm operate for a while).
3650 Most of this code was written while watching the Marlins sweep the Giants
3651 in the 1997 National League Playoffs - no Braves fans allowed to use this
3652 code (just kidding :-).
3654 I realize that if I wanted to be true to the perl tradition, the only
3655 comment in this file would be something like:
3657 ...they shuffled back towards the rear of the line. 'No, not at the
3658 rear!' the slave-driver shouted. 'Three files up. And stay there...
3660 However, I really needed to violate that tradition just so I could keep
3661 track of what happens myself, not to mention some poor fool trying to
3662 understand this years from now :-).
3665 /* ********************************************************** Configuration */
3667 #ifndef QSORT_ORDER_GUESS
3668 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3671 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3672 future processing - a good max upper bound is log base 2 of memory size
3673 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3674 safely be smaller than that since the program is taking up some space and
3675 most operating systems only let you grab some subset of contiguous
3676 memory (not to mention that you are normally sorting data larger than
3677 1 byte element size :-).
3679 #ifndef QSORT_MAX_STACK
3680 #define QSORT_MAX_STACK 32
3683 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3684 Anything bigger and we use qsort. If you make this too small, the qsort
3685 will probably break (or become less efficient), because it doesn't expect
3686 the middle element of a partition to be the same as the right or left -
3687 you have been warned).
3689 #ifndef QSORT_BREAK_EVEN
3690 #define QSORT_BREAK_EVEN 6
3693 /* ************************************************************* Data Types */
3695 /* hold left and right index values of a partition waiting to be sorted (the
3696 partition includes both left and right - right is NOT one past the end or
3697 anything like that).
3699 struct partition_stack_entry {
3702 #ifdef QSORT_ORDER_GUESS
3703 int qsort_break_even;
3707 /* ******************************************************* Shorthand Macros */
3709 /* Note that these macros will be used from inside the qsort function where
3710 we happen to know that the variable 'elt_size' contains the size of an
3711 array element and the variable 'temp' points to enough space to hold a
3712 temp element and the variable 'array' points to the array being sorted
3713 and 'compare' is the pointer to the compare routine.
3715 Also note that there are very many highly architecture specific ways
3716 these might be sped up, but this is simply the most generally portable
3717 code I could think of.
3720 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3722 #define qsort_cmp(elt1, elt2) \
3723 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3725 #ifdef QSORT_ORDER_GUESS
3726 #define QSORT_NOTICE_SWAP swapped++;
3728 #define QSORT_NOTICE_SWAP
3731 /* swaps contents of array elements elt1, elt2.
3733 #define qsort_swap(elt1, elt2) \
3736 temp = array[elt1]; \
3737 array[elt1] = array[elt2]; \
3738 array[elt2] = temp; \
3741 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3742 elt3 and elt3 gets elt1.
3744 #define qsort_rotate(elt1, elt2, elt3) \
3747 temp = array[elt1]; \
3748 array[elt1] = array[elt2]; \
3749 array[elt2] = array[elt3]; \
3750 array[elt3] = temp; \
3753 /* ************************************************************ Debug stuff */
3760 return; /* good place to set a breakpoint */
3763 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3766 doqsort_all_asserts(
3770 int (*compare)(const void * elt1, const void * elt2),
3771 int pc_left, int pc_right, int u_left, int u_right)
3775 qsort_assert(pc_left <= pc_right);
3776 qsort_assert(u_right < pc_left);
3777 qsort_assert(pc_right < u_left);
3778 for (i = u_right + 1; i < pc_left; ++i) {
3779 qsort_assert(qsort_cmp(i, pc_left) < 0);
3781 for (i = pc_left; i < pc_right; ++i) {
3782 qsort_assert(qsort_cmp(i, pc_right) == 0);
3784 for (i = pc_right + 1; i < u_left; ++i) {
3785 qsort_assert(qsort_cmp(pc_right, i) < 0);
3789 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3790 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3791 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3795 #define qsort_assert(t) ((void)0)
3797 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3801 /* ****************************************************************** qsort */
3804 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3808 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3809 int next_stack_entry = 0;
3813 #ifdef QSORT_ORDER_GUESS
3814 int qsort_break_even;
3818 /* Make sure we actually have work to do.
3820 if (num_elts <= 1) {
3824 /* Setup the initial partition definition and fall into the sorting loop
3827 part_right = (int)(num_elts - 1);
3828 #ifdef QSORT_ORDER_GUESS
3829 qsort_break_even = QSORT_BREAK_EVEN;
3831 #define qsort_break_even QSORT_BREAK_EVEN
3834 if ((part_right - part_left) >= qsort_break_even) {
3835 /* OK, this is gonna get hairy, so lets try to document all the
3836 concepts and abbreviations and variables and what they keep
3839 pc: pivot chunk - the set of array elements we accumulate in the
3840 middle of the partition, all equal in value to the original
3841 pivot element selected. The pc is defined by:
3843 pc_left - the leftmost array index of the pc
3844 pc_right - the rightmost array index of the pc
3846 we start with pc_left == pc_right and only one element
3847 in the pivot chunk (but it can grow during the scan).
3849 u: uncompared elements - the set of elements in the partition
3850 we have not yet compared to the pivot value. There are two
3851 uncompared sets during the scan - one to the left of the pc
3852 and one to the right.
3854 u_right - the rightmost index of the left side's uncompared set
3855 u_left - the leftmost index of the right side's uncompared set
3857 The leftmost index of the left sides's uncompared set
3858 doesn't need its own variable because it is always defined
3859 by the leftmost edge of the whole partition (part_left). The
3860 same goes for the rightmost edge of the right partition
3863 We know there are no uncompared elements on the left once we
3864 get u_right < part_left and no uncompared elements on the
3865 right once u_left > part_right. When both these conditions
3866 are met, we have completed the scan of the partition.
3868 Any elements which are between the pivot chunk and the
3869 uncompared elements should be less than the pivot value on
3870 the left side and greater than the pivot value on the right
3871 side (in fact, the goal of the whole algorithm is to arrange
3872 for that to be true and make the groups of less-than and
3873 greater-then elements into new partitions to sort again).
3875 As you marvel at the complexity of the code and wonder why it
3876 has to be so confusing. Consider some of the things this level
3877 of confusion brings:
3879 Once I do a compare, I squeeze every ounce of juice out of it. I
3880 never do compare calls I don't have to do, and I certainly never
3883 I also never swap any elements unless I can prove there is a
3884 good reason. Many sort algorithms will swap a known value with
3885 an uncompared value just to get things in the right place (or
3886 avoid complexity :-), but that uncompared value, once it gets
3887 compared, may then have to be swapped again. A lot of the
3888 complexity of this code is due to the fact that it never swaps
3889 anything except compared values, and it only swaps them when the
3890 compare shows they are out of position.
3892 int pc_left, pc_right;
3893 int u_right, u_left;
3897 pc_left = ((part_left + part_right) / 2);
3899 u_right = pc_left - 1;
3900 u_left = pc_right + 1;
3902 /* Qsort works best when the pivot value is also the median value
3903 in the partition (unfortunately you can't find the median value
3904 without first sorting :-), so to give the algorithm a helping
3905 hand, we pick 3 elements and sort them and use the median value
3906 of that tiny set as the pivot value.
3908 Some versions of qsort like to use the left middle and right as
3909 the 3 elements to sort so they can insure the ends of the
3910 partition will contain values which will stop the scan in the
3911 compare loop, but when you have to call an arbitrarily complex
3912 routine to do a compare, its really better to just keep track of
3913 array index values to know when you hit the edge of the
3914 partition and avoid the extra compare. An even better reason to
3915 avoid using a compare call is the fact that you can drop off the
3916 edge of the array if someone foolishly provides you with an
3917 unstable compare function that doesn't always provide consistent
3920 So, since it is simpler for us to compare the three adjacent
3921 elements in the middle of the partition, those are the ones we
3922 pick here (conveniently pointed at by u_right, pc_left, and
3923 u_left). The values of the left, center, and right elements
3924 are refered to as l c and r in the following comments.
3927 #ifdef QSORT_ORDER_GUESS
3930 s = qsort_cmp(u_right, pc_left);
3933 s = qsort_cmp(pc_left, u_left);
3934 /* if l < c, c < r - already in order - nothing to do */
3936 /* l < c, c == r - already in order, pc grows */
3938 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3940 /* l < c, c > r - need to know more */
3941 s = qsort_cmp(u_right, u_left);
3943 /* l < c, c > r, l < r - swap c & r to get ordered */
3944 qsort_swap(pc_left, u_left);
3945 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3946 } else if (s == 0) {
3947 /* l < c, c > r, l == r - swap c&r, grow pc */
3948 qsort_swap(pc_left, u_left);
3950 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3952 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3953 qsort_rotate(pc_left, u_right, u_left);
3954 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3957 } else if (s == 0) {
3959 s = qsort_cmp(pc_left, u_left);
3961 /* l == c, c < r - already in order, grow pc */
3963 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3964 } else if (s == 0) {
3965 /* l == c, c == r - already in order, grow pc both ways */
3968 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3970 /* l == c, c > r - swap l & r, grow pc */
3971 qsort_swap(u_right, u_left);
3973 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3977 s = qsort_cmp(pc_left, u_left);
3979 /* l > c, c < r - need to know more */
3980 s = qsort_cmp(u_right, u_left);
3982 /* l > c, c < r, l < r - swap l & c to get ordered */
3983 qsort_swap(u_right, pc_left);
3984 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3985 } else if (s == 0) {
3986 /* l > c, c < r, l == r - swap l & c, grow pc */
3987 qsort_swap(u_right, pc_left);
3989 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3991 /* l > c, c < r, l > r - rotate lcr into crl to order */
3992 qsort_rotate(u_right, pc_left, u_left);
3993 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3995 } else if (s == 0) {
3996 /* l > c, c == r - swap ends, grow pc */
3997 qsort_swap(u_right, u_left);
3999 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4001 /* l > c, c > r - swap ends to get in order */
4002 qsort_swap(u_right, u_left);
4003 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4006 /* We now know the 3 middle elements have been compared and
4007 arranged in the desired order, so we can shrink the uncompared
4012 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4014 /* The above massive nested if was the simple part :-). We now have
4015 the middle 3 elements ordered and we need to scan through the
4016 uncompared sets on either side, swapping elements that are on
4017 the wrong side or simply shuffling equal elements around to get
4018 all equal elements into the pivot chunk.
4022 int still_work_on_left;
4023 int still_work_on_right;
4025 /* Scan the uncompared values on the left. If I find a value
4026 equal to the pivot value, move it over so it is adjacent to
4027 the pivot chunk and expand the pivot chunk. If I find a value
4028 less than the pivot value, then just leave it - its already
4029 on the correct side of the partition. If I find a greater
4030 value, then stop the scan.
4032 while ((still_work_on_left = (u_right >= part_left))) {
4033 s = qsort_cmp(u_right, pc_left);
4036 } else if (s == 0) {
4038 if (pc_left != u_right) {
4039 qsort_swap(u_right, pc_left);
4045 qsort_assert(u_right < pc_left);
4046 qsort_assert(pc_left <= pc_right);
4047 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4048 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4051 /* Do a mirror image scan of uncompared values on the right
4053 while ((still_work_on_right = (u_left <= part_right))) {
4054 s = qsort_cmp(pc_right, u_left);
4057 } else if (s == 0) {
4059 if (pc_right != u_left) {
4060 qsort_swap(pc_right, u_left);
4066 qsort_assert(u_left > pc_right);
4067 qsort_assert(pc_left <= pc_right);
4068 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4069 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4072 if (still_work_on_left) {
4073 /* I know I have a value on the left side which needs to be
4074 on the right side, but I need to know more to decide
4075 exactly the best thing to do with it.
4077 if (still_work_on_right) {
4078 /* I know I have values on both side which are out of
4079 position. This is a big win because I kill two birds
4080 with one swap (so to speak). I can advance the
4081 uncompared pointers on both sides after swapping both
4082 of them into the right place.
4084 qsort_swap(u_right, u_left);
4087 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4089 /* I have an out of position value on the left, but the
4090 right is fully scanned, so I "slide" the pivot chunk
4091 and any less-than values left one to make room for the
4092 greater value over on the right. If the out of position
4093 value is immediately adjacent to the pivot chunk (there
4094 are no less-than values), I can do that with a swap,
4095 otherwise, I have to rotate one of the less than values
4096 into the former position of the out of position value
4097 and the right end of the pivot chunk into the left end
4101 if (pc_left == u_right) {
4102 qsort_swap(u_right, pc_right);
4103 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4105 qsort_rotate(u_right, pc_left, pc_right);
4106 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4111 } else if (still_work_on_right) {
4112 /* Mirror image of complex case above: I have an out of
4113 position value on the right, but the left is fully
4114 scanned, so I need to shuffle things around to make room
4115 for the right value on the left.
4118 if (pc_right == u_left) {
4119 qsort_swap(u_left, pc_left);
4120 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4122 qsort_rotate(pc_right, pc_left, u_left);
4123 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4128 /* No more scanning required on either side of partition,
4129 break out of loop and figure out next set of partitions
4135 /* The elements in the pivot chunk are now in the right place. They
4136 will never move or be compared again. All I have to do is decide
4137 what to do with the stuff to the left and right of the pivot
4140 Notes on the QSORT_ORDER_GUESS ifdef code:
4142 1. If I just built these partitions without swapping any (or
4143 very many) elements, there is a chance that the elements are
4144 already ordered properly (being properly ordered will
4145 certainly result in no swapping, but the converse can't be
4148 2. A (properly written) insertion sort will run faster on
4149 already ordered data than qsort will.
4151 3. Perhaps there is some way to make a good guess about
4152 switching to an insertion sort earlier than partition size 6
4153 (for instance - we could save the partition size on the stack
4154 and increase the size each time we find we didn't swap, thus
4155 switching to insertion sort earlier for partitions with a
4156 history of not swapping).
4158 4. Naturally, if I just switch right away, it will make
4159 artificial benchmarks with pure ascending (or descending)
4160 data look really good, but is that a good reason in general?
4164 #ifdef QSORT_ORDER_GUESS
4166 #if QSORT_ORDER_GUESS == 1
4167 qsort_break_even = (part_right - part_left) + 1;
4169 #if QSORT_ORDER_GUESS == 2
4170 qsort_break_even *= 2;
4172 #if QSORT_ORDER_GUESS == 3
4173 int prev_break = qsort_break_even;
4174 qsort_break_even *= qsort_break_even;
4175 if (qsort_break_even < prev_break) {
4176 qsort_break_even = (part_right - part_left) + 1;
4180 qsort_break_even = QSORT_BREAK_EVEN;
4184 if (part_left < pc_left) {
4185 /* There are elements on the left which need more processing.
4186 Check the right as well before deciding what to do.
4188 if (pc_right < part_right) {
4189 /* We have two partitions to be sorted. Stack the biggest one
4190 and process the smallest one on the next iteration. This
4191 minimizes the stack height by insuring that any additional
4192 stack entries must come from the smallest partition which
4193 (because it is smallest) will have the fewest
4194 opportunities to generate additional stack entries.
4196 if ((part_right - pc_right) > (pc_left - part_left)) {
4197 /* stack the right partition, process the left */
4198 partition_stack[next_stack_entry].left = pc_right + 1;
4199 partition_stack[next_stack_entry].right = part_right;
4200 #ifdef QSORT_ORDER_GUESS
4201 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4203 part_right = pc_left - 1;
4205 /* stack the left partition, process the right */
4206 partition_stack[next_stack_entry].left = part_left;
4207 partition_stack[next_stack_entry].right = pc_left - 1;
4208 #ifdef QSORT_ORDER_GUESS
4209 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4211 part_left = pc_right + 1;
4213 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4216 /* The elements on the left are the only remaining elements
4217 that need sorting, arrange for them to be processed as the
4220 part_right = pc_left - 1;
4222 } else if (pc_right < part_right) {
4223 /* There is only one chunk on the right to be sorted, make it
4224 the new partition and loop back around.
4226 part_left = pc_right + 1;
4228 /* This whole partition wound up in the pivot chunk, so
4229 we need to get a new partition off the stack.
4231 if (next_stack_entry == 0) {
4232 /* the stack is empty - we are done */
4236 part_left = partition_stack[next_stack_entry].left;
4237 part_right = partition_stack[next_stack_entry].right;
4238 #ifdef QSORT_ORDER_GUESS
4239 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4243 /* This partition is too small to fool with qsort complexity, just
4244 do an ordinary insertion sort to minimize overhead.
4247 /* Assume 1st element is in right place already, and start checking
4248 at 2nd element to see where it should be inserted.
4250 for (i = part_left + 1; i <= part_right; ++i) {
4252 /* Scan (backwards - just in case 'i' is already in right place)
4253 through the elements already sorted to see if the ith element
4254 belongs ahead of one of them.
4256 for (j = i - 1; j >= part_left; --j) {
4257 if (qsort_cmp(i, j) >= 0) {
4258 /* i belongs right after j
4265 /* Looks like we really need to move some things
4269 for (k = i - 1; k >= j; --k)
4270 array[k + 1] = array[k];
4275 /* That partition is now sorted, grab the next one, or get out
4276 of the loop if there aren't any more.
4279 if (next_stack_entry == 0) {
4280 /* the stack is empty - we are done */
4284 part_left = partition_stack[next_stack_entry].left;
4285 part_right = partition_stack[next_stack_entry].right;
4286 #ifdef QSORT_ORDER_GUESS
4287 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4292 /* Believe it or not, the array is sorted at this point! */
4304 sortcv(pTHXo_ SV *a, SV *b)
4307 I32 oldsaveix = PL_savestack_ix;
4308 I32 oldscopeix = PL_scopestack_ix;
4310 GvSV(PL_firstgv) = a;
4311 GvSV(PL_secondgv) = b;
4312 PL_stack_sp = PL_stack_base;
4315 if (PL_stack_sp != PL_stack_base + 1)
4316 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4317 if (!SvNIOKp(*PL_stack_sp))
4318 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4319 result = SvIV(*PL_stack_sp);
4320 while (PL_scopestack_ix > oldscopeix) {
4323 leave_scope(oldsaveix);
4328 sortcv_stacked(pTHXo_ SV *a, SV *b)
4331 I32 oldsaveix = PL_savestack_ix;
4332 I32 oldscopeix = PL_scopestack_ix;
4337 av = (AV*)PL_curpad[0];
4339 av = GvAV(PL_defgv);
4342 if (AvMAX(av) < 1) {
4343 SV** ary = AvALLOC(av);
4344 if (AvARRAY(av) != ary) {
4345 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4346 SvPVX(av) = (char*)ary;
4348 if (AvMAX(av) < 1) {
4351 SvPVX(av) = (char*)ary;
4358 PL_stack_sp = PL_stack_base;
4361 if (PL_stack_sp != PL_stack_base + 1)
4362 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4363 if (!SvNIOKp(*PL_stack_sp))
4364 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4365 result = SvIV(*PL_stack_sp);
4366 while (PL_scopestack_ix > oldscopeix) {
4369 leave_scope(oldsaveix);
4374 sortcv_xsub(pTHXo_ SV *a, SV *b)
4377 I32 oldsaveix = PL_savestack_ix;
4378 I32 oldscopeix = PL_scopestack_ix;
4380 CV *cv=(CV*)PL_sortcop;
4388 (void)(*CvXSUB(cv))(aTHXo_ cv);
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);
4403 sv_ncmp(pTHXo_ SV *a, SV *b)
4407 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4411 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4415 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4417 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4419 if (PL_amagic_generation) { \
4420 if (SvAMAGIC(left)||SvAMAGIC(right))\
4421 *svp = amagic_call(left, \
4429 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4432 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4437 I32 i = SvIVX(tmpsv);
4447 return sv_ncmp(aTHXo_ a, b);
4451 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4454 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4459 I32 i = SvIVX(tmpsv);
4469 return sv_i_ncmp(aTHXo_ a, b);
4473 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4476 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4481 I32 i = SvIVX(tmpsv);
4491 return sv_cmp(str1, str2);
4495 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4498 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4503 I32 i = SvIVX(tmpsv);
4513 return sv_cmp_locale(str1, str2);
4517 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4519 SV *datasv = FILTER_DATA(idx);
4520 int filter_has_file = IoLINES(datasv);
4521 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4522 SV *filter_state = (SV *)IoTOP_GV(datasv);
4523 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4526 /* I was having segfault trouble under Linux 2.2.5 after a
4527 parse error occured. (Had to hack around it with a test
4528 for PL_error_count == 0.) Solaris doesn't segfault --
4529 not sure where the trouble is yet. XXX */
4531 if (filter_has_file) {
4532 len = FILTER_READ(idx+1, buf_sv, maxlen);
4535 if (filter_sub && len >= 0) {
4546 PUSHs(sv_2mortal(newSViv(maxlen)));
4548 PUSHs(filter_state);
4551 count = call_sv(filter_sub, G_SCALAR);
4567 IoLINES(datasv) = 0;
4568 if (filter_child_proc) {
4569 SvREFCNT_dec(filter_child_proc);
4570 IoFMT_GV(datasv) = Nullgv;
4573 SvREFCNT_dec(filter_state);
4574 IoTOP_GV(datasv) = Nullgv;
4577 SvREFCNT_dec(filter_sub);
4578 IoBOTTOM_GV(datasv) = Nullgv;
4580 filter_del(run_user_filter);
4589 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4591 return sv_cmp_locale(str1, str2);
4595 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4597 return sv_cmp(str1, str2);
4600 #endif /* PERL_OBJECT */