3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 sortcv(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, 'r');
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
118 pm->op_pmdynflags |= PMdf_UTF8;
119 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
120 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
121 inside tie/overload accessors. */
125 #ifndef INCOMPLETE_TAINTS
128 pm->op_pmdynflags |= PMdf_TAINTED;
130 pm->op_pmdynflags &= ~PMdf_TAINTED;
134 if (!pm->op_pmregexp->prelen && PL_curpm)
136 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
137 pm->op_pmflags |= PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
161 rxres_restore(&cx->sb_rxres, rx);
163 if (cx->sb_iters++) {
164 if (cx->sb_iters > cx->sb_maxiters)
165 DIE(aTHX_ "Substitution loop");
167 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
168 cx->sb_rxtainted |= 2;
169 sv_catsv(dstr, POPs);
172 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
173 s == m, cx->sb_targ, NULL,
174 ((cx->sb_rflags & REXEC_COPY_STR)
175 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
176 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
178 SV *targ = cx->sb_targ;
179 sv_catpvn(dstr, s, cx->sb_strend - s);
181 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183 (void)SvOOK_off(targ);
184 Safefree(SvPVX(targ));
185 SvPVX(targ) = SvPVX(dstr);
186 SvCUR_set(targ, SvCUR(dstr));
187 SvLEN_set(targ, SvLEN(dstr));
191 TAINT_IF(cx->sb_rxtainted & 1);
192 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
194 (void)SvPOK_only(targ);
195 TAINT_IF(cx->sb_rxtainted);
199 LEAVE_SCOPE(cx->sb_oldsave);
201 RETURNOP(pm->op_next);
204 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
207 cx->sb_orig = orig = rx->subbeg;
209 cx->sb_strend = s + (cx->sb_strend - m);
211 cx->sb_m = m = rx->startp[0] + orig;
212 sv_catpvn(dstr, s, m-s);
213 cx->sb_s = rx->endp[0] + orig;
214 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
215 rxres_save(&cx->sb_rxres, rx);
216 RETURNOP(pm->op_pmreplstart);
220 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
225 if (!p || p[1] < rx->nparens) {
226 i = 6 + rx->nparens * 2;
234 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
235 RX_MATCH_COPIED_off(rx);
239 *p++ = PTR2UV(rx->subbeg);
240 *p++ = (UV)rx->sublen;
241 for (i = 0; i <= rx->nparens; ++i) {
242 *p++ = (UV)rx->startp[i];
243 *p++ = (UV)rx->endp[i];
248 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
253 if (RX_MATCH_COPIED(rx))
254 Safefree(rx->subbeg);
255 RX_MATCH_COPIED_set(rx, *p);
260 rx->subbeg = INT2PTR(char*,*p++);
261 rx->sublen = (I32)(*p++);
262 for (i = 0; i <= rx->nparens; ++i) {
263 rx->startp[i] = (I32)(*p++);
264 rx->endp[i] = (I32)(*p++);
269 Perl_rxres_free(pTHX_ void **rsp)
274 Safefree(INT2PTR(char*,*p));
282 djSP; dMARK; dORIGMARK;
283 register SV *tmpForm = *++MARK;
295 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
301 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
302 bool item_is_utf = FALSE;
304 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
305 if (SvREADONLY(tmpForm)) {
306 SvREADONLY_off(tmpForm);
307 doparseform(tmpForm);
308 SvREADONLY_on(tmpForm);
311 doparseform(tmpForm);
314 SvPV_force(PL_formtarget, len);
315 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
317 f = SvPV(tmpForm, len);
318 /* need to jump to the next word */
319 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
328 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
329 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
330 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
331 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
332 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
334 case FF_CHECKNL: name = "CHECKNL"; break;
335 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
336 case FF_SPACE: name = "SPACE"; break;
337 case FF_HALFSPACE: name = "HALFSPACE"; break;
338 case FF_ITEM: name = "ITEM"; break;
339 case FF_CHOP: name = "CHOP"; break;
340 case FF_LINEGLOB: name = "LINEGLOB"; break;
341 case FF_NEWLINE: name = "NEWLINE"; break;
342 case FF_MORE: name = "MORE"; break;
343 case FF_LINEMARK: name = "LINEMARK"; break;
344 case FF_END: name = "END"; break;
347 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
349 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
377 if (ckWARN(WARN_SYNTAX))
378 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
383 item = s = SvPV(sv, len);
386 itemsize = sv_len_utf8(sv);
387 if (itemsize != len) {
389 if (itemsize > fieldsize) {
390 itemsize = fieldsize;
391 itembytes = itemsize;
392 sv_pos_u2b(sv, &itembytes, 0);
396 send = chophere = s + itembytes;
406 sv_pos_b2u(sv, &itemsize);
411 if (itemsize > fieldsize)
412 itemsize = fieldsize;
413 send = chophere = s + itemsize;
425 item = s = SvPV(sv, len);
428 itemsize = sv_len_utf8(sv);
429 if (itemsize != len) {
431 if (itemsize <= fieldsize) {
432 send = chophere = s + itemsize;
443 itemsize = fieldsize;
444 itembytes = itemsize;
445 sv_pos_u2b(sv, &itembytes, 0);
446 send = chophere = s + itembytes;
447 while (s < send || (s == send && isSPACE(*s))) {
457 if (strchr(PL_chopset, *s))
462 itemsize = chophere - item;
463 sv_pos_b2u(sv, &itemsize);
470 if (itemsize <= fieldsize) {
471 send = chophere = s + itemsize;
482 itemsize = fieldsize;
483 send = chophere = s + itemsize;
484 while (s < send || (s == send && isSPACE(*s))) {
494 if (strchr(PL_chopset, *s))
499 itemsize = chophere - item;
504 arg = fieldsize - itemsize;
513 arg = fieldsize - itemsize;
528 switch (UTF8SKIP(s)) {
539 if ( !((*t++ = *s++) & ~31) )
547 int ch = *t++ = *s++;
550 if ( !((*t++ = *s++) & ~31) )
559 while (*s && isSPACE(*s))
566 item = s = SvPV(sv, len);
568 item_is_utf = FALSE; /* XXX is this correct? */
580 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
581 sv_catpvn(PL_formtarget, item, itemsize);
582 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
583 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
588 /* If the field is marked with ^ and the value is undefined,
591 if ((arg & 512) && !SvOK(sv)) {
599 /* Formats aren't yet marked for locales, so assume "yes". */
601 RESTORE_NUMERIC_LOCAL();
602 #if defined(USE_LONG_DOUBLE)
604 sprintf(t, "%#*.*" PERL_PRIfldbl,
605 (int) fieldsize, (int) arg & 255, value);
607 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
612 (int) fieldsize, (int) arg & 255, value);
615 (int) fieldsize, value);
618 RESTORE_NUMERIC_STANDARD();
625 while (t-- > linemark && *t == ' ') ;
633 if (arg) { /* repeat until fields exhausted? */
635 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
636 lines += FmLINES(PL_formtarget);
639 if (strnEQ(linemark, linemark - arg, arg))
640 DIE(aTHX_ "Runaway format");
642 FmLINES(PL_formtarget) = lines;
644 RETURNOP(cLISTOP->op_first);
657 while (*s && isSPACE(*s) && s < send)
661 arg = fieldsize - itemsize;
668 if (strnEQ(s," ",3)) {
669 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
680 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
681 FmLINES(PL_formtarget) += lines;
693 if (PL_stack_base + *PL_markstack_ptr == SP) {
695 if (GIMME_V == G_SCALAR)
696 XPUSHs(sv_2mortal(newSViv(0)));
697 RETURNOP(PL_op->op_next->op_next);
699 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
700 pp_pushmark(); /* push dst */
701 pp_pushmark(); /* push src */
702 ENTER; /* enter outer scope */
705 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
707 ENTER; /* enter inner scope */
710 src = PL_stack_base[*PL_markstack_ptr];
715 if (PL_op->op_type == OP_MAPSTART)
716 pp_pushmark(); /* push top */
717 return ((LOGOP*)PL_op->op_next)->op_other;
722 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
728 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
734 ++PL_markstack_ptr[-1];
736 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
737 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
738 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
743 PL_markstack_ptr[-1] += shift;
744 *PL_markstack_ptr += shift;
748 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
751 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
753 LEAVE; /* exit inner scope */
756 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
760 (void)POPMARK; /* pop top */
761 LEAVE; /* exit outer scope */
762 (void)POPMARK; /* pop src */
763 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
764 (void)POPMARK; /* pop dst */
765 SP = PL_stack_base + POPMARK; /* pop original mark */
766 if (gimme == G_SCALAR) {
770 else if (gimme == G_ARRAY)
777 ENTER; /* enter inner scope */
780 src = PL_stack_base[PL_markstack_ptr[-1]];
784 RETURNOP(cLOGOP->op_other);
790 djSP; dMARK; dORIGMARK;
792 SV **myorigmark = ORIGMARK;
798 OP* nextop = PL_op->op_next;
800 bool hasargs = FALSE;
803 if (gimme != G_ARRAY) {
809 SAVEVPTR(PL_sortcop);
810 if (PL_op->op_flags & OPf_STACKED) {
811 if (PL_op->op_flags & OPf_SPECIAL) {
812 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
813 kid = kUNOP->op_first; /* pass rv2gv */
814 kid = kUNOP->op_first; /* pass leave */
815 PL_sortcop = kid->op_next;
816 stash = CopSTASH(PL_curcop);
819 cv = sv_2cv(*++MARK, &stash, &gv, 0);
820 if (cv && SvPOK(cv)) {
822 char *proto = SvPV((SV*)cv, n_a);
823 if (proto && strEQ(proto, "$$")) {
827 if (!(cv && CvROOT(cv))) {
828 if (cv && CvXSUB(cv)) {
832 SV *tmpstr = sv_newmortal();
833 gv_efullname3(tmpstr, gv, Nullch);
834 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
838 DIE(aTHX_ "Undefined subroutine in sort");
843 PL_sortcop = (OP*)cv;
845 PL_sortcop = CvSTART(cv);
846 SAVEVPTR(CvROOT(cv)->op_ppaddr);
847 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
850 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
856 stash = CopSTASH(PL_curcop);
860 while (MARK < SP) { /* This may or may not shift down one here. */
862 if ((*up = *++MARK)) { /* Weed out nulls. */
864 if (!PL_sortcop && !SvPOK(*up)) {
869 (void)sv_2pv(*up, &n_a);
874 max = --up - myorigmark;
879 bool oldcatch = CATCH_GET;
885 PUSHSTACKi(PERLSI_SORT);
886 if (!hasargs && !is_xsub) {
887 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
888 SAVESPTR(PL_firstgv);
889 SAVESPTR(PL_secondgv);
890 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
891 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
892 PL_sortstash = stash;
895 Perl_lock(aTHX_ (SV *)PL_firstgv);
896 Perl_lock(aTHX_ (SV *)PL_secondgv);
898 SAVESPTR(GvSV(PL_firstgv));
899 SAVESPTR(GvSV(PL_secondgv));
902 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
903 if (!(PL_op->op_flags & OPf_SPECIAL)) {
904 cx->cx_type = CXt_SUB;
905 cx->blk_gimme = G_SCALAR;
908 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
910 PL_sortcxix = cxstack_ix;
912 if (hasargs && !is_xsub) {
913 /* This is mostly copied from pp_entersub */
914 AV *av = (AV*)PL_curpad[0];
917 cx->blk_sub.savearray = GvAV(PL_defgv);
918 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
919 #endif /* USE_THREADS */
920 cx->blk_sub.argarray = av;
922 qsortsv((myorigmark+1), max,
923 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
925 POPBLOCK(cx,PL_curpm);
933 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
934 qsortsv(ORIGMARK+1, max,
935 (PL_op->op_private & OPpSORT_NUMERIC)
936 ? ( (PL_op->op_private & OPpSORT_INTEGER)
937 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
938 : ( overloading ? amagic_ncmp : sv_ncmp))
939 : ( (PL_op->op_private & OPpLOCALE)
942 : sv_cmp_locale_static)
943 : ( overloading ? amagic_cmp : sv_cmp_static)));
944 if (PL_op->op_private & OPpSORT_REVERSE) {
946 SV **q = ORIGMARK+max;
956 PL_stack_sp = ORIGMARK + max;
964 if (GIMME == G_ARRAY)
966 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
967 return cLOGOP->op_other;
976 if (GIMME == G_ARRAY) {
977 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
981 SV *targ = PAD_SV(PL_op->op_targ);
983 if ((PL_op->op_private & OPpFLIP_LINENUM)
984 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
986 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
987 if (PL_op->op_flags & OPf_SPECIAL) {
995 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1008 if (GIMME == G_ARRAY) {
1014 if (SvGMAGICAL(left))
1016 if (SvGMAGICAL(right))
1019 if (SvNIOKp(left) || !SvPOKp(left) ||
1020 SvNIOKp(right) || !SvPOKp(right) ||
1021 (looks_like_number(left) && *SvPVX(left) != '0' &&
1022 looks_like_number(right) && *SvPVX(right) != '0'))
1024 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1025 DIE(aTHX_ "Range iterator outside integer range");
1036 sv = sv_2mortal(newSViv(i++));
1041 SV *final = sv_mortalcopy(right);
1043 char *tmps = SvPV(final, len);
1045 sv = sv_mortalcopy(left);
1047 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1049 if (strEQ(SvPVX(sv),tmps))
1051 sv = sv_2mortal(newSVsv(sv));
1058 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1060 if ((PL_op->op_private & OPpFLIP_LINENUM)
1061 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1063 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1064 sv_catpv(targ, "E0");
1075 S_dopoptolabel(pTHX_ char *label)
1079 register PERL_CONTEXT *cx;
1081 for (i = cxstack_ix; i >= 0; i--) {
1083 switch (CxTYPE(cx)) {
1085 if (ckWARN(WARN_EXITING))
1086 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1087 PL_op_name[PL_op->op_type]);
1090 if (ckWARN(WARN_EXITING))
1091 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1092 PL_op_name[PL_op->op_type]);
1095 if (ckWARN(WARN_EXITING))
1096 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1097 PL_op_name[PL_op->op_type]);
1100 if (ckWARN(WARN_EXITING))
1101 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1102 PL_op_name[PL_op->op_type]);
1105 if (ckWARN(WARN_EXITING))
1106 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1107 PL_op_name[PL_op->op_type]);
1110 if (!cx->blk_loop.label ||
1111 strNE(label, cx->blk_loop.label) ) {
1112 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1113 (long)i, cx->blk_loop.label));
1116 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1124 Perl_dowantarray(pTHX)
1126 I32 gimme = block_gimme();
1127 return (gimme == G_VOID) ? G_SCALAR : gimme;
1131 Perl_block_gimme(pTHX)
1136 cxix = dopoptosub(cxstack_ix);
1140 switch (cxstack[cxix].blk_gimme) {
1148 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1155 S_dopoptosub(pTHX_ I32 startingblock)
1158 return dopoptosub_at(cxstack, startingblock);
1162 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1166 register PERL_CONTEXT *cx;
1167 for (i = startingblock; i >= 0; i--) {
1169 switch (CxTYPE(cx)) {
1175 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1183 S_dopoptoeval(pTHX_ I32 startingblock)
1187 register PERL_CONTEXT *cx;
1188 for (i = startingblock; i >= 0; i--) {
1190 switch (CxTYPE(cx)) {
1194 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1202 S_dopoptoloop(pTHX_ I32 startingblock)
1206 register PERL_CONTEXT *cx;
1207 for (i = startingblock; i >= 0; i--) {
1209 switch (CxTYPE(cx)) {
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1213 PL_op_name[PL_op->op_type]);
1216 if (ckWARN(WARN_EXITING))
1217 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1218 PL_op_name[PL_op->op_type]);
1221 if (ckWARN(WARN_EXITING))
1222 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1223 PL_op_name[PL_op->op_type]);
1226 if (ckWARN(WARN_EXITING))
1227 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1228 PL_op_name[PL_op->op_type]);
1231 if (ckWARN(WARN_EXITING))
1232 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1233 PL_op_name[PL_op->op_type]);
1236 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1244 Perl_dounwind(pTHX_ I32 cxix)
1247 register PERL_CONTEXT *cx;
1250 while (cxstack_ix > cxix) {
1252 cx = &cxstack[cxstack_ix];
1253 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1254 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1255 /* Note: we don't need to restore the base context info till the end. */
1256 switch (CxTYPE(cx)) {
1259 continue; /* not break */
1281 * Closures mentioned at top level of eval cannot be referenced
1282 * again, and their presence indirectly causes a memory leak.
1283 * (Note that the fact that compcv and friends are still set here
1284 * is, AFAIK, an accident.) --Chip
1286 * XXX need to get comppad et al from eval's cv rather than
1287 * relying on the incidental global values.
1290 S_free_closures(pTHX)
1293 SV **svp = AvARRAY(PL_comppad_name);
1295 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1297 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1299 svp[ix] = &PL_sv_undef;
1303 SvREFCNT_dec(CvOUTSIDE(sv));
1304 CvOUTSIDE(sv) = Nullcv;
1317 Perl_qerror(pTHX_ SV *err)
1320 sv_catsv(ERRSV, err);
1322 sv_catsv(PL_errors, err);
1324 Perl_warn(aTHX_ "%"SVf, err);
1329 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1334 register PERL_CONTEXT *cx;
1339 if (PL_in_eval & EVAL_KEEPERR) {
1340 static char prefix[] = "\t(in cleanup) ";
1345 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1348 if (*e != *message || strNE(e,message))
1352 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1353 sv_catpvn(err, prefix, sizeof(prefix)-1);
1354 sv_catpvn(err, message, msglen);
1355 if (ckWARN(WARN_MISC)) {
1356 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1357 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1362 sv_setpvn(ERRSV, message, msglen);
1365 message = SvPVx(ERRSV, msglen);
1367 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1368 && PL_curstackinfo->si_prev)
1377 if (cxix < cxstack_ix)
1380 POPBLOCK(cx,PL_curpm);
1381 if (CxTYPE(cx) != CXt_EVAL) {
1382 PerlIO_write(Perl_error_log, "panic: die ", 11);
1383 PerlIO_write(Perl_error_log, message, msglen);
1388 if (gimme == G_SCALAR)
1389 *++newsp = &PL_sv_undef;
1390 PL_stack_sp = newsp;
1394 if (optype == OP_REQUIRE) {
1395 char* msg = SvPVx(ERRSV, n_a);
1396 DIE(aTHX_ "%sCompilation failed in require",
1397 *msg ? msg : "Unknown error\n");
1399 return pop_return();
1403 message = SvPVx(ERRSV, msglen);
1406 /* SFIO can really mess with your errno */
1409 PerlIO *serr = Perl_error_log;
1411 PerlIO_write(serr, message, msglen);
1412 (void)PerlIO_flush(serr);
1425 if (SvTRUE(left) != SvTRUE(right))
1437 RETURNOP(cLOGOP->op_other);
1446 RETURNOP(cLOGOP->op_other);
1452 register I32 cxix = dopoptosub(cxstack_ix);
1453 register PERL_CONTEXT *cx;
1454 register PERL_CONTEXT *ccstack = cxstack;
1455 PERL_SI *top_si = PL_curstackinfo;
1466 /* we may be in a higher stacklevel, so dig down deeper */
1467 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1468 top_si = top_si->si_prev;
1469 ccstack = top_si->si_cxstack;
1470 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1473 if (GIMME != G_ARRAY)
1477 if (PL_DBsub && cxix >= 0 &&
1478 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1482 cxix = dopoptosub_at(ccstack, cxix - 1);
1485 cx = &ccstack[cxix];
1486 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1487 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1488 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1489 field below is defined for any cx. */
1490 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1491 cx = &ccstack[dbcxix];
1494 stashname = CopSTASHPV(cx->blk_oldcop);
1495 if (GIMME != G_ARRAY) {
1497 PUSHs(&PL_sv_undef);
1500 sv_setpv(TARG, stashname);
1507 PUSHs(&PL_sv_undef);
1509 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1510 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1511 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1514 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1515 /* So is ccstack[dbcxix]. */
1517 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1518 PUSHs(sv_2mortal(sv));
1519 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1522 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1523 PUSHs(sv_2mortal(newSViv(0)));
1525 gimme = (I32)cx->blk_gimme;
1526 if (gimme == G_VOID)
1527 PUSHs(&PL_sv_undef);
1529 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1530 if (CxTYPE(cx) == CXt_EVAL) {
1532 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1533 PUSHs(cx->blk_eval.cur_text);
1537 else if (cx->blk_eval.old_namesv) {
1538 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1541 /* eval BLOCK (try blocks have old_namesv == 0) */
1543 PUSHs(&PL_sv_undef);
1544 PUSHs(&PL_sv_undef);
1548 PUSHs(&PL_sv_undef);
1549 PUSHs(&PL_sv_undef);
1551 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1552 && CopSTASH_eq(PL_curcop, PL_debstash))
1554 AV *ary = cx->blk_sub.argarray;
1555 int off = AvARRAY(ary) - AvALLOC(ary);
1559 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1562 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1565 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1566 av_extend(PL_dbargs, AvFILLp(ary) + off);
1567 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1568 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1570 /* XXX only hints propagated via op_private are currently
1571 * visible (others are not easily accessible, since they
1572 * use the global PL_hints) */
1573 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1574 HINT_PRIVATE_MASK)));
1577 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1579 if (old_warnings == pWARN_NONE ||
1580 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1581 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1582 else if (old_warnings == pWARN_ALL ||
1583 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1584 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1586 mask = newSVsv(old_warnings);
1587 PUSHs(sv_2mortal(mask));
1602 sv_reset(tmps, CopSTASH(PL_curcop));
1614 PL_curcop = (COP*)PL_op;
1615 TAINT_NOT; /* Each statement is presumed innocent */
1616 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1619 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1623 register PERL_CONTEXT *cx;
1624 I32 gimme = G_ARRAY;
1631 DIE(aTHX_ "No DB::DB routine defined");
1633 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1645 push_return(PL_op->op_next);
1646 PUSHBLOCK(cx, CXt_SUB, SP);
1649 (void)SvREFCNT_inc(cv);
1650 SAVEVPTR(PL_curpad);
1651 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1652 RETURNOP(CvSTART(cv));
1666 register PERL_CONTEXT *cx;
1667 I32 gimme = GIMME_V;
1669 U32 cxtype = CXt_LOOP;
1678 if (PL_op->op_flags & OPf_SPECIAL) {
1680 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1681 SAVEGENERICSV(*svp);
1685 #endif /* USE_THREADS */
1686 if (PL_op->op_targ) {
1687 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1690 iterdata = (void*)PL_op->op_targ;
1691 cxtype |= CXp_PADVAR;
1696 svp = &GvSV(gv); /* symbol table variable */
1697 SAVEGENERICSV(*svp);
1700 iterdata = (void*)gv;
1706 PUSHBLOCK(cx, cxtype, SP);
1708 PUSHLOOP(cx, iterdata, MARK);
1710 PUSHLOOP(cx, svp, MARK);
1712 if (PL_op->op_flags & OPf_STACKED) {
1713 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1714 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1716 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1717 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1718 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1719 looks_like_number((SV*)cx->blk_loop.iterary) &&
1720 *SvPVX(cx->blk_loop.iterary) != '0'))
1722 if (SvNV(sv) < IV_MIN ||
1723 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1724 DIE(aTHX_ "Range iterator outside integer range");
1725 cx->blk_loop.iterix = SvIV(sv);
1726 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1729 cx->blk_loop.iterlval = newSVsv(sv);
1733 cx->blk_loop.iterary = PL_curstack;
1734 AvFILLp(PL_curstack) = SP - PL_stack_base;
1735 cx->blk_loop.iterix = MARK - PL_stack_base;
1744 register PERL_CONTEXT *cx;
1745 I32 gimme = GIMME_V;
1751 PUSHBLOCK(cx, CXt_LOOP, SP);
1752 PUSHLOOP(cx, 0, SP);
1760 register PERL_CONTEXT *cx;
1768 newsp = PL_stack_base + cx->blk_loop.resetsp;
1771 if (gimme == G_VOID)
1773 else if (gimme == G_SCALAR) {
1775 *++newsp = sv_mortalcopy(*SP);
1777 *++newsp = &PL_sv_undef;
1781 *++newsp = sv_mortalcopy(*++mark);
1782 TAINT_NOT; /* Each item is independent */
1788 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1789 PL_curpm = newpm; /* ... and pop $1 et al */
1801 register PERL_CONTEXT *cx;
1802 bool popsub2 = FALSE;
1803 bool clear_errsv = FALSE;
1810 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1811 if (cxstack_ix == PL_sortcxix
1812 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1814 if (cxstack_ix > PL_sortcxix)
1815 dounwind(PL_sortcxix);
1816 AvARRAY(PL_curstack)[1] = *SP;
1817 PL_stack_sp = PL_stack_base + 1;
1822 cxix = dopoptosub(cxstack_ix);
1824 DIE(aTHX_ "Can't return outside a subroutine");
1825 if (cxix < cxstack_ix)
1829 switch (CxTYPE(cx)) {
1834 if (!(PL_in_eval & EVAL_KEEPERR))
1839 if (AvFILLp(PL_comppad_name) >= 0)
1842 if (optype == OP_REQUIRE &&
1843 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1845 /* Unassume the success we assumed earlier. */
1846 SV *nsv = cx->blk_eval.old_namesv;
1847 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1848 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1855 DIE(aTHX_ "panic: return");
1859 if (gimme == G_SCALAR) {
1862 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1864 *++newsp = SvREFCNT_inc(*SP);
1869 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1871 *++newsp = sv_mortalcopy(sv);
1876 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1879 *++newsp = sv_mortalcopy(*SP);
1882 *++newsp = &PL_sv_undef;
1884 else if (gimme == G_ARRAY) {
1885 while (++MARK <= SP) {
1886 *++newsp = (popsub2 && SvTEMP(*MARK))
1887 ? *MARK : sv_mortalcopy(*MARK);
1888 TAINT_NOT; /* Each item is independent */
1891 PL_stack_sp = newsp;
1893 /* Stack values are safe: */
1895 POPSUB(cx,sv); /* release CV and @_ ... */
1899 PL_curpm = newpm; /* ... and pop $1 et al */
1905 return pop_return();
1912 register PERL_CONTEXT *cx;
1922 if (PL_op->op_flags & OPf_SPECIAL) {
1923 cxix = dopoptoloop(cxstack_ix);
1925 DIE(aTHX_ "Can't \"last\" outside a loop block");
1928 cxix = dopoptolabel(cPVOP->op_pv);
1930 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1932 if (cxix < cxstack_ix)
1937 switch (CxTYPE(cx)) {
1940 newsp = PL_stack_base + cx->blk_loop.resetsp;
1941 nextop = cx->blk_loop.last_op->op_next;
1945 nextop = pop_return();
1949 nextop = pop_return();
1953 nextop = pop_return();
1956 DIE(aTHX_ "panic: last");
1960 if (gimme == G_SCALAR) {
1962 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1963 ? *SP : sv_mortalcopy(*SP);
1965 *++newsp = &PL_sv_undef;
1967 else if (gimme == G_ARRAY) {
1968 while (++MARK <= SP) {
1969 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1970 ? *MARK : sv_mortalcopy(*MARK);
1971 TAINT_NOT; /* Each item is independent */
1977 /* Stack values are safe: */
1980 POPLOOP(cx); /* release loop vars ... */
1984 POPSUB(cx,sv); /* release CV and @_ ... */
1987 PL_curpm = newpm; /* ... and pop $1 et al */
1997 register PERL_CONTEXT *cx;
2000 if (PL_op->op_flags & OPf_SPECIAL) {
2001 cxix = dopoptoloop(cxstack_ix);
2003 DIE(aTHX_ "Can't \"next\" outside a loop block");
2006 cxix = dopoptolabel(cPVOP->op_pv);
2008 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2010 if (cxix < cxstack_ix)
2013 /* clear off anything above the scope we're re-entering, but
2014 * save the rest until after a possible continue block */
2015 inner = PL_scopestack_ix;
2017 if (PL_scopestack_ix < inner)
2018 leave_scope(PL_scopestack[PL_scopestack_ix]);
2019 return cx->blk_loop.next_op;
2025 register PERL_CONTEXT *cx;
2028 if (PL_op->op_flags & OPf_SPECIAL) {
2029 cxix = dopoptoloop(cxstack_ix);
2031 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2034 cxix = dopoptolabel(cPVOP->op_pv);
2036 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2038 if (cxix < cxstack_ix)
2042 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2043 LEAVE_SCOPE(oldsave);
2044 return cx->blk_loop.redo_op;
2048 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2052 static char too_deep[] = "Target of goto is too deeply nested";
2055 Perl_croak(aTHX_ too_deep);
2056 if (o->op_type == OP_LEAVE ||
2057 o->op_type == OP_SCOPE ||
2058 o->op_type == OP_LEAVELOOP ||
2059 o->op_type == OP_LEAVETRY)
2061 *ops++ = cUNOPo->op_first;
2063 Perl_croak(aTHX_ too_deep);
2066 if (o->op_flags & OPf_KIDS) {
2068 /* First try all the kids at this level, since that's likeliest. */
2069 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2070 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2071 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2074 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2075 if (kid == PL_lastgotoprobe)
2077 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2079 (ops[-1]->op_type != OP_NEXTSTATE &&
2080 ops[-1]->op_type != OP_DBSTATE)))
2082 if ((o = dofindlabel(kid, label, ops, oplimit)))
2101 register PERL_CONTEXT *cx;
2102 #define GOTO_DEPTH 64
2103 OP *enterops[GOTO_DEPTH];
2105 int do_dump = (PL_op->op_type == OP_DUMP);
2106 static char must_have_label[] = "goto must have label";
2109 if (PL_op->op_flags & OPf_STACKED) {
2113 /* This egregious kludge implements goto &subroutine */
2114 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2116 register PERL_CONTEXT *cx;
2117 CV* cv = (CV*)SvRV(sv);
2123 if (!CvROOT(cv) && !CvXSUB(cv)) {
2128 /* autoloaded stub? */
2129 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2131 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2132 GvNAMELEN(gv), FALSE);
2133 if (autogv && (cv = GvCV(autogv)))
2135 tmpstr = sv_newmortal();
2136 gv_efullname3(tmpstr, gv, Nullch);
2137 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2139 DIE(aTHX_ "Goto undefined subroutine");
2142 /* First do some returnish stuff. */
2143 cxix = dopoptosub(cxstack_ix);
2145 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2146 if (cxix < cxstack_ix)
2149 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2150 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2152 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2153 /* put @_ back onto stack */
2154 AV* av = cx->blk_sub.argarray;
2156 items = AvFILLp(av) + 1;
2158 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2159 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2160 PL_stack_sp += items;
2162 SvREFCNT_dec(GvAV(PL_defgv));
2163 GvAV(PL_defgv) = cx->blk_sub.savearray;
2164 #endif /* USE_THREADS */
2165 /* abandon @_ if it got reified */
2167 (void)sv_2mortal((SV*)av); /* delay until return */
2169 av_extend(av, items-1);
2170 AvFLAGS(av) = AVf_REIFY;
2171 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2174 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2177 av = (AV*)PL_curpad[0];
2179 av = GvAV(PL_defgv);
2181 items = AvFILLp(av) + 1;
2183 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2184 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2185 PL_stack_sp += items;
2187 if (CxTYPE(cx) == CXt_SUB &&
2188 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2189 SvREFCNT_dec(cx->blk_sub.cv);
2190 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2191 LEAVE_SCOPE(oldsave);
2193 /* Now do some callish stuff. */
2196 #ifdef PERL_XSUB_OLDSTYLE
2197 if (CvOLDSTYLE(cv)) {
2198 I32 (*fp3)(int,int,int);
2203 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2204 items = (*fp3)(CvXSUBANY(cv).any_i32,
2205 mark - PL_stack_base + 1,
2207 SP = PL_stack_base + items;
2210 #endif /* PERL_XSUB_OLDSTYLE */
2215 PL_stack_sp--; /* There is no cv arg. */
2216 /* Push a mark for the start of arglist */
2218 (void)(*CvXSUB(cv))(aTHXo_ cv);
2219 /* Pop the current context like a decent sub should */
2220 POPBLOCK(cx, PL_curpm);
2221 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2224 return pop_return();
2227 AV* padlist = CvPADLIST(cv);
2228 SV** svp = AvARRAY(padlist);
2229 if (CxTYPE(cx) == CXt_EVAL) {
2230 PL_in_eval = cx->blk_eval.old_in_eval;
2231 PL_eval_root = cx->blk_eval.old_eval_root;
2232 cx->cx_type = CXt_SUB;
2233 cx->blk_sub.hasargs = 0;
2235 cx->blk_sub.cv = cv;
2236 cx->blk_sub.olddepth = CvDEPTH(cv);
2238 if (CvDEPTH(cv) < 2)
2239 (void)SvREFCNT_inc(cv);
2240 else { /* save temporaries on recursion? */
2241 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2242 sub_crush_depth(cv);
2243 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2244 AV *newpad = newAV();
2245 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2246 I32 ix = AvFILLp((AV*)svp[1]);
2247 I32 names_fill = AvFILLp((AV*)svp[0]);
2248 svp = AvARRAY(svp[0]);
2249 for ( ;ix > 0; ix--) {
2250 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2251 char *name = SvPVX(svp[ix]);
2252 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2255 /* outer lexical or anon code */
2256 av_store(newpad, ix,
2257 SvREFCNT_inc(oldpad[ix]) );
2259 else { /* our own lexical */
2261 av_store(newpad, ix, sv = (SV*)newAV());
2262 else if (*name == '%')
2263 av_store(newpad, ix, sv = (SV*)newHV());
2265 av_store(newpad, ix, sv = NEWSV(0,0));
2269 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2270 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2273 av_store(newpad, ix, sv = NEWSV(0,0));
2277 if (cx->blk_sub.hasargs) {
2280 av_store(newpad, 0, (SV*)av);
2281 AvFLAGS(av) = AVf_REIFY;
2283 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2284 AvFILLp(padlist) = CvDEPTH(cv);
2285 svp = AvARRAY(padlist);
2289 if (!cx->blk_sub.hasargs) {
2290 AV* av = (AV*)PL_curpad[0];
2292 items = AvFILLp(av) + 1;
2294 /* Mark is at the end of the stack. */
2296 Copy(AvARRAY(av), SP + 1, items, SV*);
2301 #endif /* USE_THREADS */
2302 SAVEVPTR(PL_curpad);
2303 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2305 if (cx->blk_sub.hasargs)
2306 #endif /* USE_THREADS */
2308 AV* av = (AV*)PL_curpad[0];
2312 cx->blk_sub.savearray = GvAV(PL_defgv);
2313 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2314 #endif /* USE_THREADS */
2315 cx->blk_sub.argarray = av;
2318 if (items >= AvMAX(av) + 1) {
2320 if (AvARRAY(av) != ary) {
2321 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2322 SvPVX(av) = (char*)ary;
2324 if (items >= AvMAX(av) + 1) {
2325 AvMAX(av) = items - 1;
2326 Renew(ary,items+1,SV*);
2328 SvPVX(av) = (char*)ary;
2331 Copy(mark,AvARRAY(av),items,SV*);
2332 AvFILLp(av) = items - 1;
2333 assert(!AvREAL(av));
2340 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2342 * We do not care about using sv to call CV;
2343 * it's for informational purposes only.
2345 SV *sv = GvSV(PL_DBsub);
2348 if (PERLDB_SUB_NN) {
2349 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2352 gv_efullname3(sv, CvGV(cv), Nullch);
2355 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2356 PUSHMARK( PL_stack_sp );
2357 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2361 RETURNOP(CvSTART(cv));
2365 label = SvPV(sv,n_a);
2366 if (!(do_dump || *label))
2367 DIE(aTHX_ must_have_label);
2370 else if (PL_op->op_flags & OPf_SPECIAL) {
2372 DIE(aTHX_ must_have_label);
2375 label = cPVOP->op_pv;
2377 if (label && *label) {
2382 PL_lastgotoprobe = 0;
2384 for (ix = cxstack_ix; ix >= 0; ix--) {
2386 switch (CxTYPE(cx)) {
2388 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2391 gotoprobe = cx->blk_oldcop->op_sibling;
2397 gotoprobe = cx->blk_oldcop->op_sibling;
2399 gotoprobe = PL_main_root;
2402 if (CvDEPTH(cx->blk_sub.cv)) {
2403 gotoprobe = CvROOT(cx->blk_sub.cv);
2409 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2412 DIE(aTHX_ "panic: goto");
2413 gotoprobe = PL_main_root;
2417 retop = dofindlabel(gotoprobe, label,
2418 enterops, enterops + GOTO_DEPTH);
2422 PL_lastgotoprobe = gotoprobe;
2425 DIE(aTHX_ "Can't find label %s", label);
2427 /* pop unwanted frames */
2429 if (ix < cxstack_ix) {
2436 oldsave = PL_scopestack[PL_scopestack_ix];
2437 LEAVE_SCOPE(oldsave);
2440 /* push wanted frames */
2442 if (*enterops && enterops[1]) {
2444 for (ix = 1; enterops[ix]; ix++) {
2445 PL_op = enterops[ix];
2446 /* Eventually we may want to stack the needed arguments
2447 * for each op. For now, we punt on the hard ones. */
2448 if (PL_op->op_type == OP_ENTERITER)
2449 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2450 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2458 if (!retop) retop = PL_main_start;
2460 PL_restartop = retop;
2461 PL_do_undump = TRUE;
2465 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2466 PL_do_undump = FALSE;
2482 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2486 PL_exit_flags |= PERL_EXIT_EXPECTED;
2488 PUSHs(&PL_sv_undef);
2496 NV value = SvNVx(GvSV(cCOP->cop_gv));
2497 register I32 match = I_32(value);
2500 if (((NV)match) > value)
2501 --match; /* was fractional--truncate other way */
2503 match -= cCOP->uop.scop.scop_offset;
2506 else if (match > cCOP->uop.scop.scop_max)
2507 match = cCOP->uop.scop.scop_max;
2508 PL_op = cCOP->uop.scop.scop_next[match];
2518 PL_op = PL_op->op_next; /* can't assume anything */
2521 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2522 match -= cCOP->uop.scop.scop_offset;
2525 else if (match > cCOP->uop.scop.scop_max)
2526 match = cCOP->uop.scop.scop_max;
2527 PL_op = cCOP->uop.scop.scop_next[match];
2536 S_save_lines(pTHX_ AV *array, SV *sv)
2538 register char *s = SvPVX(sv);
2539 register char *send = SvPVX(sv) + SvCUR(sv);
2541 register I32 line = 1;
2543 while (s && s < send) {
2544 SV *tmpstr = NEWSV(85,0);
2546 sv_upgrade(tmpstr, SVt_PVMG);
2547 t = strchr(s, '\n');
2553 sv_setpvn(tmpstr, s, t - s);
2554 av_store(array, line++, tmpstr);
2559 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2561 S_docatch_body(pTHX_ va_list args)
2563 return docatch_body();
2568 S_docatch_body(pTHX)
2575 S_docatch(pTHX_ OP *o)
2580 volatile PERL_SI *cursi = PL_curstackinfo;
2584 assert(CATCH_GET == TRUE);
2587 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2589 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2595 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2601 if (PL_restartop && cursi == PL_curstackinfo) {
2602 PL_op = PL_restartop;
2619 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2620 /* sv Text to convert to OP tree. */
2621 /* startop op_free() this to undo. */
2622 /* code Short string id of the caller. */
2624 dSP; /* Make POPBLOCK work. */
2627 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2631 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2632 char *tmpbuf = tbuf;
2638 /* switch to eval mode */
2640 if (PL_curcop == &PL_compiling) {
2641 SAVECOPSTASH_FREE(&PL_compiling);
2642 CopSTASH_set(&PL_compiling, PL_curstash);
2644 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2645 SV *sv = sv_newmortal();
2646 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2647 code, (unsigned long)++PL_evalseq,
2648 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2652 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2653 SAVECOPFILE_FREE(&PL_compiling);
2654 CopFILE_set(&PL_compiling, tmpbuf+2);
2655 SAVECOPLINE(&PL_compiling);
2656 CopLINE_set(&PL_compiling, 1);
2657 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2658 deleting the eval's FILEGV from the stash before gv_check() runs
2659 (i.e. before run-time proper). To work around the coredump that
2660 ensues, we always turn GvMULTI_on for any globals that were
2661 introduced within evals. See force_ident(). GSAR 96-10-12 */
2662 safestr = savepv(tmpbuf);
2663 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2665 #ifdef OP_IN_REGISTER
2673 PL_op->op_type = OP_ENTEREVAL;
2674 PL_op->op_flags = 0; /* Avoid uninit warning. */
2675 PUSHBLOCK(cx, CXt_EVAL, SP);
2676 PUSHEVAL(cx, 0, Nullgv);
2677 rop = doeval(G_SCALAR, startop);
2678 POPBLOCK(cx,PL_curpm);
2681 (*startop)->op_type = OP_NULL;
2682 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2684 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2686 if (PL_curcop == &PL_compiling)
2687 PL_compiling.op_private = PL_hints;
2688 #ifdef OP_IN_REGISTER
2694 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2696 S_doeval(pTHX_ int gimme, OP** startop)
2704 PL_in_eval = EVAL_INEVAL;
2708 /* set up a scratch pad */
2711 SAVEVPTR(PL_curpad);
2712 SAVESPTR(PL_comppad);
2713 SAVESPTR(PL_comppad_name);
2714 SAVEI32(PL_comppad_name_fill);
2715 SAVEI32(PL_min_intro_pending);
2716 SAVEI32(PL_max_intro_pending);
2719 for (i = cxstack_ix - 1; i >= 0; i--) {
2720 PERL_CONTEXT *cx = &cxstack[i];
2721 if (CxTYPE(cx) == CXt_EVAL)
2723 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2724 caller = cx->blk_sub.cv;
2729 SAVESPTR(PL_compcv);
2730 PL_compcv = (CV*)NEWSV(1104,0);
2731 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2732 CvEVAL_on(PL_compcv);
2734 CvOWNER(PL_compcv) = 0;
2735 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2736 MUTEX_INIT(CvMUTEXP(PL_compcv));
2737 #endif /* USE_THREADS */
2739 PL_comppad = newAV();
2740 av_push(PL_comppad, Nullsv);
2741 PL_curpad = AvARRAY(PL_comppad);
2742 PL_comppad_name = newAV();
2743 PL_comppad_name_fill = 0;
2744 PL_min_intro_pending = 0;
2747 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2748 PL_curpad[0] = (SV*)newAV();
2749 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2750 #endif /* USE_THREADS */
2752 comppadlist = newAV();
2753 AvREAL_off(comppadlist);
2754 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2755 av_store(comppadlist, 1, (SV*)PL_comppad);
2756 CvPADLIST(PL_compcv) = comppadlist;
2759 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2761 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2764 SAVEFREESV(PL_compcv);
2766 /* make sure we compile in the right package */
2768 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2769 SAVESPTR(PL_curstash);
2770 PL_curstash = CopSTASH(PL_curcop);
2772 SAVESPTR(PL_beginav);
2773 PL_beginav = newAV();
2774 SAVEFREESV(PL_beginav);
2775 SAVEI32(PL_error_count);
2777 /* try to compile it */
2779 PL_eval_root = Nullop;
2781 PL_curcop = &PL_compiling;
2782 PL_curcop->cop_arybase = 0;
2783 SvREFCNT_dec(PL_rs);
2784 PL_rs = newSVpvn("\n", 1);
2785 if (saveop && saveop->op_flags & OPf_SPECIAL)
2786 PL_in_eval |= EVAL_KEEPERR;
2789 if (yyparse() || PL_error_count || !PL_eval_root) {
2793 I32 optype = 0; /* Might be reset by POPEVAL. */
2798 op_free(PL_eval_root);
2799 PL_eval_root = Nullop;
2801 SP = PL_stack_base + POPMARK; /* pop original mark */
2803 POPBLOCK(cx,PL_curpm);
2809 if (optype == OP_REQUIRE) {
2810 char* msg = SvPVx(ERRSV, n_a);
2811 DIE(aTHX_ "%sCompilation failed in require",
2812 *msg ? msg : "Unknown error\n");
2815 char* msg = SvPVx(ERRSV, n_a);
2817 POPBLOCK(cx,PL_curpm);
2819 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2820 (*msg ? msg : "Unknown error\n"));
2822 SvREFCNT_dec(PL_rs);
2823 PL_rs = SvREFCNT_inc(PL_nrs);
2825 MUTEX_LOCK(&PL_eval_mutex);
2827 COND_SIGNAL(&PL_eval_cond);
2828 MUTEX_UNLOCK(&PL_eval_mutex);
2829 #endif /* USE_THREADS */
2832 SvREFCNT_dec(PL_rs);
2833 PL_rs = SvREFCNT_inc(PL_nrs);
2834 CopLINE_set(&PL_compiling, 0);
2836 *startop = PL_eval_root;
2837 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2838 CvOUTSIDE(PL_compcv) = Nullcv;
2840 SAVEFREEOP(PL_eval_root);
2842 scalarvoid(PL_eval_root);
2843 else if (gimme & G_ARRAY)
2846 scalar(PL_eval_root);
2848 DEBUG_x(dump_eval());
2850 /* Register with debugger: */
2851 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2852 CV *cv = get_cv("DB::postponed", FALSE);
2856 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2858 call_sv((SV*)cv, G_DISCARD);
2862 /* compiled okay, so do it */
2864 CvDEPTH(PL_compcv) = 1;
2865 SP = PL_stack_base + POPMARK; /* pop original mark */
2866 PL_op = saveop; /* The caller may need it. */
2868 MUTEX_LOCK(&PL_eval_mutex);
2870 COND_SIGNAL(&PL_eval_cond);
2871 MUTEX_UNLOCK(&PL_eval_mutex);
2872 #endif /* USE_THREADS */
2874 RETURNOP(PL_eval_start);
2878 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2880 STRLEN namelen = strlen(name);
2883 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2884 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2885 char *pmc = SvPV_nolen(pmcsv);
2888 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2889 fp = PerlIO_open(name, mode);
2892 if (PerlLIO_stat(name, &pmstat) < 0 ||
2893 pmstat.st_mtime < pmcstat.st_mtime)
2895 fp = PerlIO_open(pmc, mode);
2898 fp = PerlIO_open(name, mode);
2901 SvREFCNT_dec(pmcsv);
2904 fp = PerlIO_open(name, mode);
2912 register PERL_CONTEXT *cx;
2917 SV *namesv = Nullsv;
2919 I32 gimme = G_SCALAR;
2920 PerlIO *tryrsfp = 0;
2922 int filter_has_file = 0;
2923 GV *filter_child_proc = 0;
2924 SV *filter_state = 0;
2929 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2930 UV rev = 0, ver = 0, sver = 0;
2932 U8 *s = (U8*)SvPVX(sv);
2933 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2935 rev = utf8_to_uv(s, &len);
2938 ver = utf8_to_uv(s, &len);
2941 sver = utf8_to_uv(s, &len);
2944 if (PERL_REVISION < rev
2945 || (PERL_REVISION == rev
2946 && (PERL_VERSION < ver
2947 || (PERL_VERSION == ver
2948 && PERL_SUBVERSION < sver))))
2950 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2951 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2952 PERL_VERSION, PERL_SUBVERSION);
2956 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2957 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2958 + ((NV)PERL_SUBVERSION/(NV)1000000)
2959 + 0.00000099 < SvNV(sv))
2963 NV nver = (nrev - rev) * 1000;
2964 UV ver = (UV)(nver + 0.0009);
2965 NV nsver = (nver - ver) * 1000;
2966 UV sver = (UV)(nsver + 0.0009);
2968 /* help out with the "use 5.6" confusion */
2969 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2970 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2971 "this is only v%d.%d.%d, stopped"
2972 " (did you mean v%"UVuf".%"UVuf".0?)",
2973 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2974 PERL_SUBVERSION, rev, ver/100);
2977 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2978 "this is only v%d.%d.%d, stopped",
2979 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2986 name = SvPV(sv, len);
2987 if (!(name && len > 0 && *name))
2988 DIE(aTHX_ "Null filename used");
2989 TAINT_PROPER("require");
2990 if (PL_op->op_type == OP_REQUIRE &&
2991 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2992 *svp != &PL_sv_undef)
2995 /* prepare to compile file */
2997 if (PERL_FILE_IS_ABSOLUTE(name)
2998 || (*name == '.' && (name[1] == '/' ||
2999 (name[1] == '.' && name[2] == '/'))))
3002 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3003 #ifdef MACOS_TRADITIONAL
3004 /* We consider paths of the form :a:b ambiguous and interpret them first
3005 as global then as local
3007 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3016 AV *ar = GvAVn(PL_incgv);
3020 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3023 namesv = NEWSV(806, 0);
3024 for (i = 0; i <= AvFILL(ar); i++) {
3025 SV *dirsv = *av_fetch(ar, i, TRUE);
3031 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3032 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3035 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3036 PTR2UV(SvANY(loader)), name);
3037 tryname = SvPVX(namesv);
3048 count = call_sv(loader, G_ARRAY);
3058 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3062 if (SvTYPE(arg) == SVt_PVGV) {
3063 IO *io = GvIO((GV *)arg);
3068 tryrsfp = IoIFP(io);
3069 if (IoTYPE(io) == '|') {
3070 /* reading from a child process doesn't
3071 nest -- when returning from reading
3072 the inner module, the outer one is
3073 unreadable (closed?) I've tried to
3074 save the gv to manage the lifespan of
3075 the pipe, but this didn't help. XXX */
3076 filter_child_proc = (GV *)arg;
3077 (void)SvREFCNT_inc(filter_child_proc);
3080 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3081 PerlIO_close(IoOFP(io));
3093 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3095 (void)SvREFCNT_inc(filter_sub);
3098 filter_state = SP[i];
3099 (void)SvREFCNT_inc(filter_state);
3103 tryrsfp = PerlIO_open("/dev/null",
3117 filter_has_file = 0;
3118 if (filter_child_proc) {
3119 SvREFCNT_dec(filter_child_proc);
3120 filter_child_proc = 0;
3123 SvREFCNT_dec(filter_state);
3127 SvREFCNT_dec(filter_sub);
3132 char *dir = SvPVx(dirsv, n_a);
3133 #ifdef MACOS_TRADITIONAL
3134 /* We have ensured in incpush that library ends with ':' */
3135 Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':'));
3139 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3141 sv_setpv(namesv, unixdir);
3142 sv_catpv(namesv, unixname);
3144 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3147 TAINT_PROPER("require");
3148 tryname = SvPVX(namesv);
3149 #ifdef MACOS_TRADITIONAL
3151 /* Convert slashes in the name part, but not the directory part, to colons */
3153 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3157 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3159 if (tryname[0] == '.' && tryname[1] == '/')
3167 SAVECOPFILE_FREE(&PL_compiling);
3168 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3169 SvREFCNT_dec(namesv);
3171 if (PL_op->op_type == OP_REQUIRE) {
3172 char *msgstr = name;
3173 if (namesv) { /* did we lookup @INC? */
3174 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3175 SV *dirmsgsv = NEWSV(0, 0);
3176 AV *ar = GvAVn(PL_incgv);
3178 sv_catpvn(msg, " in @INC", 8);
3179 if (instr(SvPVX(msg), ".h "))
3180 sv_catpv(msg, " (change .h to .ph maybe?)");
3181 if (instr(SvPVX(msg), ".ph "))
3182 sv_catpv(msg, " (did you run h2ph?)");
3183 sv_catpv(msg, " (@INC contains:");
3184 for (i = 0; i <= AvFILL(ar); i++) {
3185 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3186 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3187 sv_catsv(msg, dirmsgsv);
3189 sv_catpvn(msg, ")", 1);
3190 SvREFCNT_dec(dirmsgsv);
3191 msgstr = SvPV_nolen(msg);
3193 DIE(aTHX_ "Can't locate %s", msgstr);
3199 SETERRNO(0, SS$_NORMAL);
3201 /* Assume success here to prevent recursive requirement. */
3202 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3203 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3207 lex_start(sv_2mortal(newSVpvn("",0)));
3208 SAVEGENERICSV(PL_rsfp_filters);
3209 PL_rsfp_filters = Nullav;
3214 SAVESPTR(PL_compiling.cop_warnings);
3215 if (PL_dowarn & G_WARN_ALL_ON)
3216 PL_compiling.cop_warnings = pWARN_ALL ;
3217 else if (PL_dowarn & G_WARN_ALL_OFF)
3218 PL_compiling.cop_warnings = pWARN_NONE ;
3220 PL_compiling.cop_warnings = pWARN_STD ;
3222 if (filter_sub || filter_child_proc) {
3223 SV *datasv = filter_add(run_user_filter, Nullsv);
3224 IoLINES(datasv) = filter_has_file;
3225 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3226 IoTOP_GV(datasv) = (GV *)filter_state;
3227 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3230 /* switch to eval mode */
3231 push_return(PL_op->op_next);
3232 PUSHBLOCK(cx, CXt_EVAL, SP);
3233 PUSHEVAL(cx, name, Nullgv);
3235 SAVECOPLINE(&PL_compiling);
3236 CopLINE_set(&PL_compiling, 0);
3240 MUTEX_LOCK(&PL_eval_mutex);
3241 if (PL_eval_owner && PL_eval_owner != thr)
3242 while (PL_eval_owner)
3243 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3244 PL_eval_owner = thr;
3245 MUTEX_UNLOCK(&PL_eval_mutex);
3246 #endif /* USE_THREADS */
3247 return DOCATCH(doeval(G_SCALAR, NULL));
3252 return pp_require();
3258 register PERL_CONTEXT *cx;
3260 I32 gimme = GIMME_V, was = PL_sub_generation;
3261 char tbuf[TYPE_DIGITS(long) + 12];
3262 char *tmpbuf = tbuf;
3267 if (!SvPV(sv,len) || !len)
3269 TAINT_PROPER("eval");
3275 /* switch to eval mode */
3277 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3278 SV *sv = sv_newmortal();
3279 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3280 (unsigned long)++PL_evalseq,
3281 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3285 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3286 SAVECOPFILE_FREE(&PL_compiling);
3287 CopFILE_set(&PL_compiling, tmpbuf+2);
3288 SAVECOPLINE(&PL_compiling);
3289 CopLINE_set(&PL_compiling, 1);
3290 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3291 deleting the eval's FILEGV from the stash before gv_check() runs
3292 (i.e. before run-time proper). To work around the coredump that
3293 ensues, we always turn GvMULTI_on for any globals that were
3294 introduced within evals. See force_ident(). GSAR 96-10-12 */
3295 safestr = savepv(tmpbuf);
3296 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3298 PL_hints = PL_op->op_targ;
3299 SAVESPTR(PL_compiling.cop_warnings);
3300 if (specialWARN(PL_curcop->cop_warnings))
3301 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3303 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3304 SAVEFREESV(PL_compiling.cop_warnings);
3307 push_return(PL_op->op_next);
3308 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3309 PUSHEVAL(cx, 0, Nullgv);
3311 /* prepare to compile string */
3313 if (PERLDB_LINE && PL_curstash != PL_debstash)
3314 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3317 MUTEX_LOCK(&PL_eval_mutex);
3318 if (PL_eval_owner && PL_eval_owner != thr)
3319 while (PL_eval_owner)
3320 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3321 PL_eval_owner = thr;
3322 MUTEX_UNLOCK(&PL_eval_mutex);
3323 #endif /* USE_THREADS */
3324 ret = doeval(gimme, NULL);
3325 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3326 && ret != PL_op->op_next) { /* Successive compilation. */
3327 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3329 return DOCATCH(ret);
3339 register PERL_CONTEXT *cx;
3341 U8 save_flags = PL_op -> op_flags;
3346 retop = pop_return();
3349 if (gimme == G_VOID)
3351 else if (gimme == G_SCALAR) {
3354 if (SvFLAGS(TOPs) & SVs_TEMP)
3357 *MARK = sv_mortalcopy(TOPs);
3361 *MARK = &PL_sv_undef;
3366 /* in case LEAVE wipes old return values */
3367 for (mark = newsp + 1; mark <= SP; mark++) {
3368 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3369 *mark = sv_mortalcopy(*mark);
3370 TAINT_NOT; /* Each item is independent */
3374 PL_curpm = newpm; /* Don't pop $1 et al till now */
3376 if (AvFILLp(PL_comppad_name) >= 0)
3380 assert(CvDEPTH(PL_compcv) == 1);
3382 CvDEPTH(PL_compcv) = 0;
3385 if (optype == OP_REQUIRE &&
3386 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3388 /* Unassume the success we assumed earlier. */
3389 SV *nsv = cx->blk_eval.old_namesv;
3390 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3391 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3392 /* die_where() did LEAVE, or we won't be here */
3396 if (!(save_flags & OPf_SPECIAL))
3406 register PERL_CONTEXT *cx;
3407 I32 gimme = GIMME_V;
3412 push_return(cLOGOP->op_other->op_next);
3413 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3415 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3417 PL_in_eval = EVAL_INEVAL;
3420 return DOCATCH(PL_op->op_next);
3430 register PERL_CONTEXT *cx;
3438 if (gimme == G_VOID)
3440 else if (gimme == G_SCALAR) {
3443 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3446 *MARK = sv_mortalcopy(TOPs);
3450 *MARK = &PL_sv_undef;
3455 /* in case LEAVE wipes old return values */
3456 for (mark = newsp + 1; mark <= SP; mark++) {
3457 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3458 *mark = sv_mortalcopy(*mark);
3459 TAINT_NOT; /* Each item is independent */
3463 PL_curpm = newpm; /* Don't pop $1 et al till now */
3471 S_doparseform(pTHX_ SV *sv)
3474 register char *s = SvPV_force(sv, len);
3475 register char *send = s + len;
3476 register char *base;
3477 register I32 skipspaces = 0;
3480 bool postspace = FALSE;
3488 Perl_croak(aTHX_ "Null picture in formline");
3490 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3495 *fpc++ = FF_LINEMARK;
3496 noblank = repeat = FALSE;
3514 case ' ': case '\t':
3525 *fpc++ = FF_LITERAL;
3533 *fpc++ = skipspaces;
3537 *fpc++ = FF_NEWLINE;
3541 arg = fpc - linepc + 1;
3548 *fpc++ = FF_LINEMARK;
3549 noblank = repeat = FALSE;
3558 ischop = s[-1] == '^';
3564 arg = (s - base) - 1;
3566 *fpc++ = FF_LITERAL;
3575 *fpc++ = FF_LINEGLOB;
3577 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3578 arg = ischop ? 512 : 0;
3588 arg |= 256 + (s - f);
3590 *fpc++ = s - base; /* fieldsize for FETCH */
3591 *fpc++ = FF_DECIMAL;
3596 bool ismore = FALSE;
3599 while (*++s == '>') ;
3600 prespace = FF_SPACE;
3602 else if (*s == '|') {
3603 while (*++s == '|') ;
3604 prespace = FF_HALFSPACE;
3609 while (*++s == '<') ;
3612 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3616 *fpc++ = s - base; /* fieldsize for FETCH */
3618 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3636 { /* need to jump to the next word */
3638 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3639 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3640 s = SvPVX(sv) + SvCUR(sv) + z;
3642 Copy(fops, s, arg, U16);
3644 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3649 * The rest of this file was derived from source code contributed
3652 * NOTE: this code was derived from Tom Horsley's qsort replacement
3653 * and should not be confused with the original code.
3656 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3658 Permission granted to distribute under the same terms as perl which are
3661 This program is free software; you can redistribute it and/or modify
3662 it under the terms of either:
3664 a) the GNU General Public License as published by the Free
3665 Software Foundation; either version 1, or (at your option) any
3668 b) the "Artistic License" which comes with this Kit.
3670 Details on the perl license can be found in the perl source code which
3671 may be located via the www.perl.com web page.
3673 This is the most wonderfulest possible qsort I can come up with (and
3674 still be mostly portable) My (limited) tests indicate it consistently
3675 does about 20% fewer calls to compare than does the qsort in the Visual
3676 C++ library, other vendors may vary.
3678 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3679 others I invented myself (or more likely re-invented since they seemed
3680 pretty obvious once I watched the algorithm operate for a while).
3682 Most of this code was written while watching the Marlins sweep the Giants
3683 in the 1997 National League Playoffs - no Braves fans allowed to use this
3684 code (just kidding :-).
3686 I realize that if I wanted to be true to the perl tradition, the only
3687 comment in this file would be something like:
3689 ...they shuffled back towards the rear of the line. 'No, not at the
3690 rear!' the slave-driver shouted. 'Three files up. And stay there...
3692 However, I really needed to violate that tradition just so I could keep
3693 track of what happens myself, not to mention some poor fool trying to
3694 understand this years from now :-).
3697 /* ********************************************************** Configuration */
3699 #ifndef QSORT_ORDER_GUESS
3700 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3703 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3704 future processing - a good max upper bound is log base 2 of memory size
3705 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3706 safely be smaller than that since the program is taking up some space and
3707 most operating systems only let you grab some subset of contiguous
3708 memory (not to mention that you are normally sorting data larger than
3709 1 byte element size :-).
3711 #ifndef QSORT_MAX_STACK
3712 #define QSORT_MAX_STACK 32
3715 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3716 Anything bigger and we use qsort. If you make this too small, the qsort
3717 will probably break (or become less efficient), because it doesn't expect
3718 the middle element of a partition to be the same as the right or left -
3719 you have been warned).
3721 #ifndef QSORT_BREAK_EVEN
3722 #define QSORT_BREAK_EVEN 6
3725 /* ************************************************************* Data Types */
3727 /* hold left and right index values of a partition waiting to be sorted (the
3728 partition includes both left and right - right is NOT one past the end or
3729 anything like that).
3731 struct partition_stack_entry {
3734 #ifdef QSORT_ORDER_GUESS
3735 int qsort_break_even;
3739 /* ******************************************************* Shorthand Macros */
3741 /* Note that these macros will be used from inside the qsort function where
3742 we happen to know that the variable 'elt_size' contains the size of an
3743 array element and the variable 'temp' points to enough space to hold a
3744 temp element and the variable 'array' points to the array being sorted
3745 and 'compare' is the pointer to the compare routine.
3747 Also note that there are very many highly architecture specific ways
3748 these might be sped up, but this is simply the most generally portable
3749 code I could think of.
3752 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3754 #define qsort_cmp(elt1, elt2) \
3755 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3757 #ifdef QSORT_ORDER_GUESS
3758 #define QSORT_NOTICE_SWAP swapped++;
3760 #define QSORT_NOTICE_SWAP
3763 /* swaps contents of array elements elt1, elt2.
3765 #define qsort_swap(elt1, elt2) \
3768 temp = array[elt1]; \
3769 array[elt1] = array[elt2]; \
3770 array[elt2] = temp; \
3773 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3774 elt3 and elt3 gets elt1.
3776 #define qsort_rotate(elt1, elt2, elt3) \
3779 temp = array[elt1]; \
3780 array[elt1] = array[elt2]; \
3781 array[elt2] = array[elt3]; \
3782 array[elt3] = temp; \
3785 /* ************************************************************ Debug stuff */
3792 return; /* good place to set a breakpoint */
3795 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3798 doqsort_all_asserts(
3802 int (*compare)(const void * elt1, const void * elt2),
3803 int pc_left, int pc_right, int u_left, int u_right)
3807 qsort_assert(pc_left <= pc_right);
3808 qsort_assert(u_right < pc_left);
3809 qsort_assert(pc_right < u_left);
3810 for (i = u_right + 1; i < pc_left; ++i) {
3811 qsort_assert(qsort_cmp(i, pc_left) < 0);
3813 for (i = pc_left; i < pc_right; ++i) {
3814 qsort_assert(qsort_cmp(i, pc_right) == 0);
3816 for (i = pc_right + 1; i < u_left; ++i) {
3817 qsort_assert(qsort_cmp(pc_right, i) < 0);
3821 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3822 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3823 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3827 #define qsort_assert(t) ((void)0)
3829 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3833 /* ****************************************************************** qsort */
3836 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3840 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3841 int next_stack_entry = 0;
3845 #ifdef QSORT_ORDER_GUESS
3846 int qsort_break_even;
3850 /* Make sure we actually have work to do.
3852 if (num_elts <= 1) {
3856 /* Setup the initial partition definition and fall into the sorting loop
3859 part_right = (int)(num_elts - 1);
3860 #ifdef QSORT_ORDER_GUESS
3861 qsort_break_even = QSORT_BREAK_EVEN;
3863 #define qsort_break_even QSORT_BREAK_EVEN
3866 if ((part_right - part_left) >= qsort_break_even) {
3867 /* OK, this is gonna get hairy, so lets try to document all the
3868 concepts and abbreviations and variables and what they keep
3871 pc: pivot chunk - the set of array elements we accumulate in the
3872 middle of the partition, all equal in value to the original
3873 pivot element selected. The pc is defined by:
3875 pc_left - the leftmost array index of the pc
3876 pc_right - the rightmost array index of the pc
3878 we start with pc_left == pc_right and only one element
3879 in the pivot chunk (but it can grow during the scan).
3881 u: uncompared elements - the set of elements in the partition
3882 we have not yet compared to the pivot value. There are two
3883 uncompared sets during the scan - one to the left of the pc
3884 and one to the right.
3886 u_right - the rightmost index of the left side's uncompared set
3887 u_left - the leftmost index of the right side's uncompared set
3889 The leftmost index of the left sides's uncompared set
3890 doesn't need its own variable because it is always defined
3891 by the leftmost edge of the whole partition (part_left). The
3892 same goes for the rightmost edge of the right partition
3895 We know there are no uncompared elements on the left once we
3896 get u_right < part_left and no uncompared elements on the
3897 right once u_left > part_right. When both these conditions
3898 are met, we have completed the scan of the partition.
3900 Any elements which are between the pivot chunk and the
3901 uncompared elements should be less than the pivot value on
3902 the left side and greater than the pivot value on the right
3903 side (in fact, the goal of the whole algorithm is to arrange
3904 for that to be true and make the groups of less-than and
3905 greater-then elements into new partitions to sort again).
3907 As you marvel at the complexity of the code and wonder why it
3908 has to be so confusing. Consider some of the things this level
3909 of confusion brings:
3911 Once I do a compare, I squeeze every ounce of juice out of it. I
3912 never do compare calls I don't have to do, and I certainly never
3915 I also never swap any elements unless I can prove there is a
3916 good reason. Many sort algorithms will swap a known value with
3917 an uncompared value just to get things in the right place (or
3918 avoid complexity :-), but that uncompared value, once it gets
3919 compared, may then have to be swapped again. A lot of the
3920 complexity of this code is due to the fact that it never swaps
3921 anything except compared values, and it only swaps them when the
3922 compare shows they are out of position.
3924 int pc_left, pc_right;
3925 int u_right, u_left;
3929 pc_left = ((part_left + part_right) / 2);
3931 u_right = pc_left - 1;
3932 u_left = pc_right + 1;
3934 /* Qsort works best when the pivot value is also the median value
3935 in the partition (unfortunately you can't find the median value
3936 without first sorting :-), so to give the algorithm a helping
3937 hand, we pick 3 elements and sort them and use the median value
3938 of that tiny set as the pivot value.
3940 Some versions of qsort like to use the left middle and right as
3941 the 3 elements to sort so they can insure the ends of the
3942 partition will contain values which will stop the scan in the
3943 compare loop, but when you have to call an arbitrarily complex
3944 routine to do a compare, its really better to just keep track of
3945 array index values to know when you hit the edge of the
3946 partition and avoid the extra compare. An even better reason to
3947 avoid using a compare call is the fact that you can drop off the
3948 edge of the array if someone foolishly provides you with an
3949 unstable compare function that doesn't always provide consistent
3952 So, since it is simpler for us to compare the three adjacent
3953 elements in the middle of the partition, those are the ones we
3954 pick here (conveniently pointed at by u_right, pc_left, and
3955 u_left). The values of the left, center, and right elements
3956 are refered to as l c and r in the following comments.
3959 #ifdef QSORT_ORDER_GUESS
3962 s = qsort_cmp(u_right, pc_left);
3965 s = qsort_cmp(pc_left, u_left);
3966 /* if l < c, c < r - already in order - nothing to do */
3968 /* l < c, c == r - already in order, pc grows */
3970 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3972 /* l < c, c > r - need to know more */
3973 s = qsort_cmp(u_right, u_left);
3975 /* l < c, c > r, l < r - swap c & r to get ordered */
3976 qsort_swap(pc_left, u_left);
3977 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3978 } else if (s == 0) {
3979 /* l < c, c > r, l == r - swap c&r, grow pc */
3980 qsort_swap(pc_left, u_left);
3982 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3984 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3985 qsort_rotate(pc_left, u_right, u_left);
3986 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3989 } else if (s == 0) {
3991 s = qsort_cmp(pc_left, u_left);
3993 /* l == c, c < r - already in order, grow pc */
3995 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3996 } else if (s == 0) {
3997 /* l == c, c == r - already in order, grow pc both ways */
4000 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4002 /* l == c, c > r - swap l & r, grow pc */
4003 qsort_swap(u_right, u_left);
4005 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4009 s = qsort_cmp(pc_left, u_left);
4011 /* l > c, c < r - need to know more */
4012 s = qsort_cmp(u_right, u_left);
4014 /* l > c, c < r, l < r - swap l & c to get ordered */
4015 qsort_swap(u_right, pc_left);
4016 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4017 } else if (s == 0) {
4018 /* l > c, c < r, l == r - swap l & c, grow pc */
4019 qsort_swap(u_right, pc_left);
4021 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4023 /* l > c, c < r, l > r - rotate lcr into crl to order */
4024 qsort_rotate(u_right, pc_left, u_left);
4025 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4027 } else if (s == 0) {
4028 /* l > c, c == r - swap ends, grow pc */
4029 qsort_swap(u_right, u_left);
4031 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4033 /* l > c, c > r - swap ends to get in order */
4034 qsort_swap(u_right, u_left);
4035 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4038 /* We now know the 3 middle elements have been compared and
4039 arranged in the desired order, so we can shrink the uncompared
4044 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4046 /* The above massive nested if was the simple part :-). We now have
4047 the middle 3 elements ordered and we need to scan through the
4048 uncompared sets on either side, swapping elements that are on
4049 the wrong side or simply shuffling equal elements around to get
4050 all equal elements into the pivot chunk.
4054 int still_work_on_left;
4055 int still_work_on_right;
4057 /* Scan the uncompared values on the left. If I find a value
4058 equal to the pivot value, move it over so it is adjacent to
4059 the pivot chunk and expand the pivot chunk. If I find a value
4060 less than the pivot value, then just leave it - its already
4061 on the correct side of the partition. If I find a greater
4062 value, then stop the scan.
4064 while ((still_work_on_left = (u_right >= part_left))) {
4065 s = qsort_cmp(u_right, pc_left);
4068 } else if (s == 0) {
4070 if (pc_left != u_right) {
4071 qsort_swap(u_right, pc_left);
4077 qsort_assert(u_right < pc_left);
4078 qsort_assert(pc_left <= pc_right);
4079 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4080 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4083 /* Do a mirror image scan of uncompared values on the right
4085 while ((still_work_on_right = (u_left <= part_right))) {
4086 s = qsort_cmp(pc_right, u_left);
4089 } else if (s == 0) {
4091 if (pc_right != u_left) {
4092 qsort_swap(pc_right, u_left);
4098 qsort_assert(u_left > pc_right);
4099 qsort_assert(pc_left <= pc_right);
4100 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4101 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4104 if (still_work_on_left) {
4105 /* I know I have a value on the left side which needs to be
4106 on the right side, but I need to know more to decide
4107 exactly the best thing to do with it.
4109 if (still_work_on_right) {
4110 /* I know I have values on both side which are out of
4111 position. This is a big win because I kill two birds
4112 with one swap (so to speak). I can advance the
4113 uncompared pointers on both sides after swapping both
4114 of them into the right place.
4116 qsort_swap(u_right, u_left);
4119 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4121 /* I have an out of position value on the left, but the
4122 right is fully scanned, so I "slide" the pivot chunk
4123 and any less-than values left one to make room for the
4124 greater value over on the right. If the out of position
4125 value is immediately adjacent to the pivot chunk (there
4126 are no less-than values), I can do that with a swap,
4127 otherwise, I have to rotate one of the less than values
4128 into the former position of the out of position value
4129 and the right end of the pivot chunk into the left end
4133 if (pc_left == u_right) {
4134 qsort_swap(u_right, pc_right);
4135 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4137 qsort_rotate(u_right, pc_left, pc_right);
4138 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4143 } else if (still_work_on_right) {
4144 /* Mirror image of complex case above: I have an out of
4145 position value on the right, but the left is fully
4146 scanned, so I need to shuffle things around to make room
4147 for the right value on the left.
4150 if (pc_right == u_left) {
4151 qsort_swap(u_left, pc_left);
4152 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4154 qsort_rotate(pc_right, pc_left, u_left);
4155 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4160 /* No more scanning required on either side of partition,
4161 break out of loop and figure out next set of partitions
4167 /* The elements in the pivot chunk are now in the right place. They
4168 will never move or be compared again. All I have to do is decide
4169 what to do with the stuff to the left and right of the pivot
4172 Notes on the QSORT_ORDER_GUESS ifdef code:
4174 1. If I just built these partitions without swapping any (or
4175 very many) elements, there is a chance that the elements are
4176 already ordered properly (being properly ordered will
4177 certainly result in no swapping, but the converse can't be
4180 2. A (properly written) insertion sort will run faster on
4181 already ordered data than qsort will.
4183 3. Perhaps there is some way to make a good guess about
4184 switching to an insertion sort earlier than partition size 6
4185 (for instance - we could save the partition size on the stack
4186 and increase the size each time we find we didn't swap, thus
4187 switching to insertion sort earlier for partitions with a
4188 history of not swapping).
4190 4. Naturally, if I just switch right away, it will make
4191 artificial benchmarks with pure ascending (or descending)
4192 data look really good, but is that a good reason in general?
4196 #ifdef QSORT_ORDER_GUESS
4198 #if QSORT_ORDER_GUESS == 1
4199 qsort_break_even = (part_right - part_left) + 1;
4201 #if QSORT_ORDER_GUESS == 2
4202 qsort_break_even *= 2;
4204 #if QSORT_ORDER_GUESS == 3
4205 int prev_break = qsort_break_even;
4206 qsort_break_even *= qsort_break_even;
4207 if (qsort_break_even < prev_break) {
4208 qsort_break_even = (part_right - part_left) + 1;
4212 qsort_break_even = QSORT_BREAK_EVEN;
4216 if (part_left < pc_left) {
4217 /* There are elements on the left which need more processing.
4218 Check the right as well before deciding what to do.
4220 if (pc_right < part_right) {
4221 /* We have two partitions to be sorted. Stack the biggest one
4222 and process the smallest one on the next iteration. This
4223 minimizes the stack height by insuring that any additional
4224 stack entries must come from the smallest partition which
4225 (because it is smallest) will have the fewest
4226 opportunities to generate additional stack entries.
4228 if ((part_right - pc_right) > (pc_left - part_left)) {
4229 /* stack the right partition, process the left */
4230 partition_stack[next_stack_entry].left = pc_right + 1;
4231 partition_stack[next_stack_entry].right = part_right;
4232 #ifdef QSORT_ORDER_GUESS
4233 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4235 part_right = pc_left - 1;
4237 /* stack the left partition, process the right */
4238 partition_stack[next_stack_entry].left = part_left;
4239 partition_stack[next_stack_entry].right = pc_left - 1;
4240 #ifdef QSORT_ORDER_GUESS
4241 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4243 part_left = pc_right + 1;
4245 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4248 /* The elements on the left are the only remaining elements
4249 that need sorting, arrange for them to be processed as the
4252 part_right = pc_left - 1;
4254 } else if (pc_right < part_right) {
4255 /* There is only one chunk on the right to be sorted, make it
4256 the new partition and loop back around.
4258 part_left = pc_right + 1;
4260 /* This whole partition wound up in the pivot chunk, so
4261 we need to get a new partition off the stack.
4263 if (next_stack_entry == 0) {
4264 /* the stack is empty - we are done */
4268 part_left = partition_stack[next_stack_entry].left;
4269 part_right = partition_stack[next_stack_entry].right;
4270 #ifdef QSORT_ORDER_GUESS
4271 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4275 /* This partition is too small to fool with qsort complexity, just
4276 do an ordinary insertion sort to minimize overhead.
4279 /* Assume 1st element is in right place already, and start checking
4280 at 2nd element to see where it should be inserted.
4282 for (i = part_left + 1; i <= part_right; ++i) {
4284 /* Scan (backwards - just in case 'i' is already in right place)
4285 through the elements already sorted to see if the ith element
4286 belongs ahead of one of them.
4288 for (j = i - 1; j >= part_left; --j) {
4289 if (qsort_cmp(i, j) >= 0) {
4290 /* i belongs right after j
4297 /* Looks like we really need to move some things
4301 for (k = i - 1; k >= j; --k)
4302 array[k + 1] = array[k];
4307 /* That partition is now sorted, grab the next one, or get out
4308 of the loop if there aren't any more.
4311 if (next_stack_entry == 0) {
4312 /* the stack is empty - we are done */
4316 part_left = partition_stack[next_stack_entry].left;
4317 part_right = partition_stack[next_stack_entry].right;
4318 #ifdef QSORT_ORDER_GUESS
4319 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4324 /* Believe it or not, the array is sorted at this point! */
4336 sortcv(pTHXo_ SV *a, SV *b)
4339 I32 oldsaveix = PL_savestack_ix;
4340 I32 oldscopeix = PL_scopestack_ix;
4342 GvSV(PL_firstgv) = a;
4343 GvSV(PL_secondgv) = b;
4344 PL_stack_sp = PL_stack_base;
4347 if (PL_stack_sp != PL_stack_base + 1)
4348 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4349 if (!SvNIOKp(*PL_stack_sp))
4350 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4351 result = SvIV(*PL_stack_sp);
4352 while (PL_scopestack_ix > oldscopeix) {
4355 leave_scope(oldsaveix);
4360 sortcv_stacked(pTHXo_ SV *a, SV *b)
4363 I32 oldsaveix = PL_savestack_ix;
4364 I32 oldscopeix = PL_scopestack_ix;
4369 av = (AV*)PL_curpad[0];
4371 av = GvAV(PL_defgv);
4374 if (AvMAX(av) < 1) {
4375 SV** ary = AvALLOC(av);
4376 if (AvARRAY(av) != ary) {
4377 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4378 SvPVX(av) = (char*)ary;
4380 if (AvMAX(av) < 1) {
4383 SvPVX(av) = (char*)ary;
4390 PL_stack_sp = PL_stack_base;
4393 if (PL_stack_sp != PL_stack_base + 1)
4394 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4395 if (!SvNIOKp(*PL_stack_sp))
4396 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4397 result = SvIV(*PL_stack_sp);
4398 while (PL_scopestack_ix > oldscopeix) {
4401 leave_scope(oldsaveix);
4406 sortcv_xsub(pTHXo_ SV *a, SV *b)
4409 I32 oldsaveix = PL_savestack_ix;
4410 I32 oldscopeix = PL_scopestack_ix;
4412 CV *cv=(CV*)PL_sortcop;
4420 (void)(*CvXSUB(cv))(aTHXo_ cv);
4421 if (PL_stack_sp != PL_stack_base + 1)
4422 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4423 if (!SvNIOKp(*PL_stack_sp))
4424 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4425 result = SvIV(*PL_stack_sp);
4426 while (PL_scopestack_ix > oldscopeix) {
4429 leave_scope(oldsaveix);
4435 sv_ncmp(pTHXo_ SV *a, SV *b)
4439 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4443 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4447 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4449 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4451 if (PL_amagic_generation) { \
4452 if (SvAMAGIC(left)||SvAMAGIC(right))\
4453 *svp = amagic_call(left, \
4461 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4464 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4469 I32 i = SvIVX(tmpsv);
4479 return sv_ncmp(aTHXo_ a, b);
4483 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4486 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4491 I32 i = SvIVX(tmpsv);
4501 return sv_i_ncmp(aTHXo_ a, b);
4505 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4508 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4513 I32 i = SvIVX(tmpsv);
4523 return sv_cmp(str1, str2);
4527 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4530 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4535 I32 i = SvIVX(tmpsv);
4545 return sv_cmp_locale(str1, str2);
4549 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4551 SV *datasv = FILTER_DATA(idx);
4552 int filter_has_file = IoLINES(datasv);
4553 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4554 SV *filter_state = (SV *)IoTOP_GV(datasv);
4555 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4558 /* I was having segfault trouble under Linux 2.2.5 after a
4559 parse error occured. (Had to hack around it with a test
4560 for PL_error_count == 0.) Solaris doesn't segfault --
4561 not sure where the trouble is yet. XXX */
4563 if (filter_has_file) {
4564 len = FILTER_READ(idx+1, buf_sv, maxlen);
4567 if (filter_sub && len >= 0) {
4578 PUSHs(sv_2mortal(newSViv(maxlen)));
4580 PUSHs(filter_state);
4583 count = call_sv(filter_sub, G_SCALAR);
4599 IoLINES(datasv) = 0;
4600 if (filter_child_proc) {
4601 SvREFCNT_dec(filter_child_proc);
4602 IoFMT_GV(datasv) = Nullgv;
4605 SvREFCNT_dec(filter_state);
4606 IoTOP_GV(datasv) = Nullgv;
4609 SvREFCNT_dec(filter_sub);
4610 IoBOTTOM_GV(datasv) = Nullgv;
4612 filter_del(run_user_filter);
4621 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4623 return sv_cmp_locale(str1, str2);
4627 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4629 return sv_cmp(str1, str2);
4632 #endif /* PERL_OBJECT */