3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 sortcv(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, 'r');
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
118 pm->op_pmdynflags |= PMdf_UTF8;
119 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
120 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
121 inside tie/overload accessors. */
125 #ifndef INCOMPLETE_TAINTS
128 pm->op_pmdynflags |= PMdf_TAINTED;
130 pm->op_pmdynflags &= ~PMdf_TAINTED;
134 if (!pm->op_pmregexp->prelen && PL_curpm)
136 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
137 pm->op_pmflags |= PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
161 rxres_restore(&cx->sb_rxres, rx);
163 if (cx->sb_iters++) {
164 if (cx->sb_iters > cx->sb_maxiters)
165 DIE(aTHX_ "Substitution loop");
167 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
168 cx->sb_rxtainted |= 2;
169 sv_catsv(dstr, POPs);
172 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
173 s == m, cx->sb_targ, NULL,
174 ((cx->sb_rflags & REXEC_COPY_STR)
175 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
176 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
178 SV *targ = cx->sb_targ;
179 sv_catpvn(dstr, s, cx->sb_strend - s);
181 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183 (void)SvOOK_off(targ);
184 Safefree(SvPVX(targ));
185 SvPVX(targ) = SvPVX(dstr);
186 SvCUR_set(targ, SvCUR(dstr));
187 SvLEN_set(targ, SvLEN(dstr));
191 TAINT_IF(cx->sb_rxtainted & 1);
192 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
194 (void)SvPOK_only(targ);
195 TAINT_IF(cx->sb_rxtainted);
199 LEAVE_SCOPE(cx->sb_oldsave);
201 RETURNOP(pm->op_next);
204 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
207 cx->sb_orig = orig = rx->subbeg;
209 cx->sb_strend = s + (cx->sb_strend - m);
211 cx->sb_m = m = rx->startp[0] + orig;
212 sv_catpvn(dstr, s, m-s);
213 cx->sb_s = rx->endp[0] + orig;
214 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
215 rxres_save(&cx->sb_rxres, rx);
216 RETURNOP(pm->op_pmreplstart);
220 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
225 if (!p || p[1] < rx->nparens) {
226 i = 6 + rx->nparens * 2;
234 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
235 RX_MATCH_COPIED_off(rx);
239 *p++ = PTR2UV(rx->subbeg);
240 *p++ = (UV)rx->sublen;
241 for (i = 0; i <= rx->nparens; ++i) {
242 *p++ = (UV)rx->startp[i];
243 *p++ = (UV)rx->endp[i];
248 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
253 if (RX_MATCH_COPIED(rx))
254 Safefree(rx->subbeg);
255 RX_MATCH_COPIED_set(rx, *p);
260 rx->subbeg = INT2PTR(char*,*p++);
261 rx->sublen = (I32)(*p++);
262 for (i = 0; i <= rx->nparens; ++i) {
263 rx->startp[i] = (I32)(*p++);
264 rx->endp[i] = (I32)(*p++);
269 Perl_rxres_free(pTHX_ void **rsp)
274 Safefree(INT2PTR(char*,*p));
282 djSP; dMARK; dORIGMARK;
283 register SV *tmpForm = *++MARK;
295 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
301 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
302 bool item_is_utf = FALSE;
304 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
305 if (SvREADONLY(tmpForm)) {
306 SvREADONLY_off(tmpForm);
307 doparseform(tmpForm);
308 SvREADONLY_on(tmpForm);
311 doparseform(tmpForm);
314 SvPV_force(PL_formtarget, len);
315 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
317 f = SvPV(tmpForm, len);
318 /* need to jump to the next word */
319 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
328 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
329 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
330 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
331 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
332 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
334 case FF_CHECKNL: name = "CHECKNL"; break;
335 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
336 case FF_SPACE: name = "SPACE"; break;
337 case FF_HALFSPACE: name = "HALFSPACE"; break;
338 case FF_ITEM: name = "ITEM"; break;
339 case FF_CHOP: name = "CHOP"; break;
340 case FF_LINEGLOB: name = "LINEGLOB"; break;
341 case FF_NEWLINE: name = "NEWLINE"; break;
342 case FF_MORE: name = "MORE"; break;
343 case FF_LINEMARK: name = "LINEMARK"; break;
344 case FF_END: name = "END"; break;
347 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
349 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
377 if (ckWARN(WARN_SYNTAX))
378 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
383 item = s = SvPV(sv, len);
386 itemsize = sv_len_utf8(sv);
387 if (itemsize != len) {
389 if (itemsize > fieldsize) {
390 itemsize = fieldsize;
391 itembytes = itemsize;
392 sv_pos_u2b(sv, &itembytes, 0);
396 send = chophere = s + itembytes;
406 sv_pos_b2u(sv, &itemsize);
411 if (itemsize > fieldsize)
412 itemsize = fieldsize;
413 send = chophere = s + itemsize;
425 item = s = SvPV(sv, len);
428 itemsize = sv_len_utf8(sv);
429 if (itemsize != len) {
431 if (itemsize <= fieldsize) {
432 send = chophere = s + itemsize;
443 itemsize = fieldsize;
444 itembytes = itemsize;
445 sv_pos_u2b(sv, &itembytes, 0);
446 send = chophere = s + itembytes;
447 while (s < send || (s == send && isSPACE(*s))) {
457 if (strchr(PL_chopset, *s))
462 itemsize = chophere - item;
463 sv_pos_b2u(sv, &itemsize);
470 if (itemsize <= fieldsize) {
471 send = chophere = s + itemsize;
482 itemsize = fieldsize;
483 send = chophere = s + itemsize;
484 while (s < send || (s == send && isSPACE(*s))) {
494 if (strchr(PL_chopset, *s))
499 itemsize = chophere - item;
504 arg = fieldsize - itemsize;
513 arg = fieldsize - itemsize;
528 switch (UTF8SKIP(s)) {
539 if ( !((*t++ = *s++) & ~31) )
547 int ch = *t++ = *s++;
550 if ( !((*t++ = *s++) & ~31) )
559 while (*s && isSPACE(*s))
566 item = s = SvPV(sv, len);
568 item_is_utf = FALSE; /* XXX is this correct? */
580 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
581 sv_catpvn(PL_formtarget, item, itemsize);
582 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
583 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
588 /* If the field is marked with ^ and the value is undefined,
591 if ((arg & 512) && !SvOK(sv)) {
599 /* Formats aren't yet marked for locales, so assume "yes". */
601 RESTORE_NUMERIC_LOCAL();
602 #if defined(USE_LONG_DOUBLE)
604 sprintf(t, "%#*.*" PERL_PRIfldbl,
605 (int) fieldsize, (int) arg & 255, value);
607 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
612 (int) fieldsize, (int) arg & 255, value);
615 (int) fieldsize, value);
618 RESTORE_NUMERIC_STANDARD();
625 while (t-- > linemark && *t == ' ') ;
633 if (arg) { /* repeat until fields exhausted? */
635 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
636 lines += FmLINES(PL_formtarget);
639 if (strnEQ(linemark, linemark - arg, arg))
640 DIE(aTHX_ "Runaway format");
642 FmLINES(PL_formtarget) = lines;
644 RETURNOP(cLISTOP->op_first);
657 while (*s && isSPACE(*s) && s < send)
661 arg = fieldsize - itemsize;
668 if (strnEQ(s," ",3)) {
669 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
680 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
681 FmLINES(PL_formtarget) += lines;
693 if (PL_stack_base + *PL_markstack_ptr == SP) {
695 if (GIMME_V == G_SCALAR)
696 XPUSHs(sv_2mortal(newSViv(0)));
697 RETURNOP(PL_op->op_next->op_next);
699 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
700 pp_pushmark(); /* push dst */
701 pp_pushmark(); /* push src */
702 ENTER; /* enter outer scope */
705 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
707 ENTER; /* enter inner scope */
710 src = PL_stack_base[*PL_markstack_ptr];
715 if (PL_op->op_type == OP_MAPSTART)
716 pp_pushmark(); /* push top */
717 return ((LOGOP*)PL_op->op_next)->op_other;
722 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
728 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
734 ++PL_markstack_ptr[-1];
736 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
737 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
738 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
743 PL_markstack_ptr[-1] += shift;
744 *PL_markstack_ptr += shift;
748 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
751 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
753 LEAVE; /* exit inner scope */
756 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
760 (void)POPMARK; /* pop top */
761 LEAVE; /* exit outer scope */
762 (void)POPMARK; /* pop src */
763 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
764 (void)POPMARK; /* pop dst */
765 SP = PL_stack_base + POPMARK; /* pop original mark */
766 if (gimme == G_SCALAR) {
770 else if (gimme == G_ARRAY)
777 ENTER; /* enter inner scope */
780 src = PL_stack_base[PL_markstack_ptr[-1]];
784 RETURNOP(cLOGOP->op_other);
790 djSP; dMARK; dORIGMARK;
792 SV **myorigmark = ORIGMARK;
798 OP* nextop = PL_op->op_next;
800 bool hasargs = FALSE;
803 if (gimme != G_ARRAY) {
809 SAVEVPTR(PL_sortcop);
810 if (PL_op->op_flags & OPf_STACKED) {
811 if (PL_op->op_flags & OPf_SPECIAL) {
812 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
813 kid = kUNOP->op_first; /* pass rv2gv */
814 kid = kUNOP->op_first; /* pass leave */
815 PL_sortcop = kid->op_next;
816 stash = CopSTASH(PL_curcop);
819 cv = sv_2cv(*++MARK, &stash, &gv, 0);
820 if (cv && SvPOK(cv)) {
822 char *proto = SvPV((SV*)cv, n_a);
823 if (proto && strEQ(proto, "$$")) {
827 if (!(cv && CvROOT(cv))) {
828 if (cv && CvXSUB(cv)) {
832 SV *tmpstr = sv_newmortal();
833 gv_efullname3(tmpstr, gv, Nullch);
834 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
838 DIE(aTHX_ "Undefined subroutine in sort");
843 PL_sortcop = (OP*)cv;
845 PL_sortcop = CvSTART(cv);
846 SAVEVPTR(CvROOT(cv)->op_ppaddr);
847 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
850 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
856 stash = CopSTASH(PL_curcop);
860 while (MARK < SP) { /* This may or may not shift down one here. */
862 if ((*up = *++MARK)) { /* Weed out nulls. */
864 if (!PL_sortcop && !SvPOK(*up)) {
869 (void)sv_2pv(*up, &n_a);
874 max = --up - myorigmark;
879 bool oldcatch = CATCH_GET;
885 PUSHSTACKi(PERLSI_SORT);
886 if (PL_sortstash != stash) {
887 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
888 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
889 PL_sortstash = stash;
892 SAVESPTR(GvSV(PL_firstgv));
893 SAVESPTR(GvSV(PL_secondgv));
895 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
896 if (!(PL_op->op_flags & OPf_SPECIAL)) {
897 cx->cx_type = CXt_SUB;
898 cx->blk_gimme = G_SCALAR;
901 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
903 PL_sortcxix = cxstack_ix;
905 if (hasargs && !is_xsub) {
906 /* This is mostly copied from pp_entersub */
907 AV *av = (AV*)PL_curpad[0];
910 cx->blk_sub.savearray = GvAV(PL_defgv);
911 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
912 #endif /* USE_THREADS */
913 cx->blk_sub.argarray = av;
915 qsortsv((myorigmark+1), max,
916 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
918 POPBLOCK(cx,PL_curpm);
926 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
927 qsortsv(ORIGMARK+1, max,
928 (PL_op->op_private & OPpSORT_NUMERIC)
929 ? ( (PL_op->op_private & OPpSORT_INTEGER)
930 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
931 : ( overloading ? amagic_ncmp : sv_ncmp))
932 : ( (PL_op->op_private & OPpLOCALE)
935 : sv_cmp_locale_static)
936 : ( overloading ? amagic_cmp : sv_cmp_static)));
937 if (PL_op->op_private & OPpSORT_REVERSE) {
939 SV **q = ORIGMARK+max;
949 PL_stack_sp = ORIGMARK + max;
957 if (GIMME == G_ARRAY)
959 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
960 return cLOGOP->op_other;
969 if (GIMME == G_ARRAY) {
970 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
974 SV *targ = PAD_SV(PL_op->op_targ);
976 if ((PL_op->op_private & OPpFLIP_LINENUM)
977 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
979 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
980 if (PL_op->op_flags & OPf_SPECIAL) {
988 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1001 if (GIMME == G_ARRAY) {
1007 if (SvGMAGICAL(left))
1009 if (SvGMAGICAL(right))
1012 if (SvNIOKp(left) || !SvPOKp(left) ||
1013 SvNIOKp(right) || !SvPOKp(right) ||
1014 (looks_like_number(left) && *SvPVX(left) != '0' &&
1015 looks_like_number(right) && *SvPVX(right) != '0'))
1017 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1018 DIE(aTHX_ "Range iterator outside integer range");
1029 sv = sv_2mortal(newSViv(i++));
1034 SV *final = sv_mortalcopy(right);
1036 char *tmps = SvPV(final, len);
1038 sv = sv_mortalcopy(left);
1040 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1042 if (strEQ(SvPVX(sv),tmps))
1044 sv = sv_2mortal(newSVsv(sv));
1051 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1053 if ((PL_op->op_private & OPpFLIP_LINENUM)
1054 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1056 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1057 sv_catpv(targ, "E0");
1068 S_dopoptolabel(pTHX_ char *label)
1072 register PERL_CONTEXT *cx;
1074 for (i = cxstack_ix; i >= 0; i--) {
1076 switch (CxTYPE(cx)) {
1078 if (ckWARN(WARN_EXITING))
1079 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1080 PL_op_name[PL_op->op_type]);
1083 if (ckWARN(WARN_EXITING))
1084 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1085 PL_op_name[PL_op->op_type]);
1088 if (ckWARN(WARN_EXITING))
1089 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1090 PL_op_name[PL_op->op_type]);
1093 if (ckWARN(WARN_EXITING))
1094 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1095 PL_op_name[PL_op->op_type]);
1098 if (ckWARN(WARN_EXITING))
1099 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1100 PL_op_name[PL_op->op_type]);
1103 if (!cx->blk_loop.label ||
1104 strNE(label, cx->blk_loop.label) ) {
1105 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1106 (long)i, cx->blk_loop.label));
1109 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1117 Perl_dowantarray(pTHX)
1119 I32 gimme = block_gimme();
1120 return (gimme == G_VOID) ? G_SCALAR : gimme;
1124 Perl_block_gimme(pTHX)
1129 cxix = dopoptosub(cxstack_ix);
1133 switch (cxstack[cxix].blk_gimme) {
1141 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1148 S_dopoptosub(pTHX_ I32 startingblock)
1151 return dopoptosub_at(cxstack, startingblock);
1155 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1159 register PERL_CONTEXT *cx;
1160 for (i = startingblock; i >= 0; i--) {
1162 switch (CxTYPE(cx)) {
1168 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1176 S_dopoptoeval(pTHX_ I32 startingblock)
1180 register PERL_CONTEXT *cx;
1181 for (i = startingblock; i >= 0; i--) {
1183 switch (CxTYPE(cx)) {
1187 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1195 S_dopoptoloop(pTHX_ I32 startingblock)
1199 register PERL_CONTEXT *cx;
1200 for (i = startingblock; i >= 0; i--) {
1202 switch (CxTYPE(cx)) {
1204 if (ckWARN(WARN_EXITING))
1205 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1206 PL_op_name[PL_op->op_type]);
1209 if (ckWARN(WARN_EXITING))
1210 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1211 PL_op_name[PL_op->op_type]);
1214 if (ckWARN(WARN_EXITING))
1215 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1216 PL_op_name[PL_op->op_type]);
1219 if (ckWARN(WARN_EXITING))
1220 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1221 PL_op_name[PL_op->op_type]);
1224 if (ckWARN(WARN_EXITING))
1225 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1226 PL_op_name[PL_op->op_type]);
1229 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1237 Perl_dounwind(pTHX_ I32 cxix)
1240 register PERL_CONTEXT *cx;
1243 while (cxstack_ix > cxix) {
1245 cx = &cxstack[cxstack_ix];
1246 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1247 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1248 /* Note: we don't need to restore the base context info till the end. */
1249 switch (CxTYPE(cx)) {
1252 continue; /* not break */
1274 * Closures mentioned at top level of eval cannot be referenced
1275 * again, and their presence indirectly causes a memory leak.
1276 * (Note that the fact that compcv and friends are still set here
1277 * is, AFAIK, an accident.) --Chip
1279 * XXX need to get comppad et al from eval's cv rather than
1280 * relying on the incidental global values.
1283 S_free_closures(pTHX)
1286 SV **svp = AvARRAY(PL_comppad_name);
1288 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1290 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1292 svp[ix] = &PL_sv_undef;
1296 SvREFCNT_dec(CvOUTSIDE(sv));
1297 CvOUTSIDE(sv) = Nullcv;
1310 Perl_qerror(pTHX_ SV *err)
1313 sv_catsv(ERRSV, err);
1315 sv_catsv(PL_errors, err);
1317 Perl_warn(aTHX_ "%"SVf, err);
1322 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1327 register PERL_CONTEXT *cx;
1332 if (PL_in_eval & EVAL_KEEPERR) {
1333 static char prefix[] = "\t(in cleanup) ";
1338 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1341 if (*e != *message || strNE(e,message))
1345 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1346 sv_catpvn(err, prefix, sizeof(prefix)-1);
1347 sv_catpvn(err, message, msglen);
1348 if (ckWARN(WARN_MISC)) {
1349 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1350 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1355 sv_setpvn(ERRSV, message, msglen);
1358 message = SvPVx(ERRSV, msglen);
1360 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1361 && PL_curstackinfo->si_prev)
1370 if (cxix < cxstack_ix)
1373 POPBLOCK(cx,PL_curpm);
1374 if (CxTYPE(cx) != CXt_EVAL) {
1375 PerlIO_write(Perl_error_log, "panic: die ", 11);
1376 PerlIO_write(Perl_error_log, message, msglen);
1381 if (gimme == G_SCALAR)
1382 *++newsp = &PL_sv_undef;
1383 PL_stack_sp = newsp;
1387 if (optype == OP_REQUIRE) {
1388 char* msg = SvPVx(ERRSV, n_a);
1389 DIE(aTHX_ "%sCompilation failed in require",
1390 *msg ? msg : "Unknown error\n");
1392 return pop_return();
1396 message = SvPVx(ERRSV, msglen);
1399 /* SFIO can really mess with your errno */
1402 PerlIO *serr = Perl_error_log;
1404 PerlIO_write(serr, message, msglen);
1405 (void)PerlIO_flush(serr);
1418 if (SvTRUE(left) != SvTRUE(right))
1430 RETURNOP(cLOGOP->op_other);
1439 RETURNOP(cLOGOP->op_other);
1445 register I32 cxix = dopoptosub(cxstack_ix);
1446 register PERL_CONTEXT *cx;
1447 register PERL_CONTEXT *ccstack = cxstack;
1448 PERL_SI *top_si = PL_curstackinfo;
1459 /* we may be in a higher stacklevel, so dig down deeper */
1460 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1461 top_si = top_si->si_prev;
1462 ccstack = top_si->si_cxstack;
1463 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1466 if (GIMME != G_ARRAY)
1470 if (PL_DBsub && cxix >= 0 &&
1471 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1475 cxix = dopoptosub_at(ccstack, cxix - 1);
1478 cx = &ccstack[cxix];
1479 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1480 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1481 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1482 field below is defined for any cx. */
1483 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1484 cx = &ccstack[dbcxix];
1487 stashname = CopSTASHPV(cx->blk_oldcop);
1488 if (GIMME != G_ARRAY) {
1490 PUSHs(&PL_sv_undef);
1493 sv_setpv(TARG, stashname);
1500 PUSHs(&PL_sv_undef);
1502 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1503 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1504 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1507 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1508 /* So is ccstack[dbcxix]. */
1510 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1511 PUSHs(sv_2mortal(sv));
1512 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1515 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1516 PUSHs(sv_2mortal(newSViv(0)));
1518 gimme = (I32)cx->blk_gimme;
1519 if (gimme == G_VOID)
1520 PUSHs(&PL_sv_undef);
1522 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1523 if (CxTYPE(cx) == CXt_EVAL) {
1524 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1525 PUSHs(cx->blk_eval.cur_text);
1528 /* try blocks have old_namesv == 0 */
1529 else if (cx->blk_eval.old_namesv) {
1530 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1535 PUSHs(&PL_sv_undef);
1536 PUSHs(&PL_sv_undef);
1538 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1539 && CopSTASH_eq(PL_curcop, PL_debstash))
1541 AV *ary = cx->blk_sub.argarray;
1542 int off = AvARRAY(ary) - AvALLOC(ary);
1546 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1549 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1552 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1553 av_extend(PL_dbargs, AvFILLp(ary) + off);
1554 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1555 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1557 /* XXX only hints propagated via op_private are currently
1558 * visible (others are not easily accessible, since they
1559 * use the global PL_hints) */
1560 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1561 HINT_PRIVATE_MASK)));
1564 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1565 if (old_warnings == WARN_NONE || old_warnings == WARN_STD)
1566 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1567 else if (old_warnings == WARN_ALL)
1568 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1570 mask = newSVsv(old_warnings);
1571 PUSHs(sv_2mortal(mask));
1586 sv_reset(tmps, CopSTASH(PL_curcop));
1598 PL_curcop = (COP*)PL_op;
1599 TAINT_NOT; /* Each statement is presumed innocent */
1600 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1603 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1607 register PERL_CONTEXT *cx;
1608 I32 gimme = G_ARRAY;
1615 DIE(aTHX_ "No DB::DB routine defined");
1617 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1629 push_return(PL_op->op_next);
1630 PUSHBLOCK(cx, CXt_SUB, SP);
1633 (void)SvREFCNT_inc(cv);
1634 SAVEVPTR(PL_curpad);
1635 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1636 RETURNOP(CvSTART(cv));
1650 register PERL_CONTEXT *cx;
1651 I32 gimme = GIMME_V;
1653 U32 cxtype = CXt_LOOP;
1662 if (PL_op->op_flags & OPf_SPECIAL) {
1664 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1665 SAVEGENERICSV(*svp);
1669 #endif /* USE_THREADS */
1670 if (PL_op->op_targ) {
1671 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1674 iterdata = (void*)PL_op->op_targ;
1675 cxtype |= CXp_PADVAR;
1680 svp = &GvSV(gv); /* symbol table variable */
1681 SAVEGENERICSV(*svp);
1684 iterdata = (void*)gv;
1690 PUSHBLOCK(cx, cxtype, SP);
1692 PUSHLOOP(cx, iterdata, MARK);
1694 PUSHLOOP(cx, svp, MARK);
1696 if (PL_op->op_flags & OPf_STACKED) {
1697 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1698 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1700 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1701 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1702 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1703 looks_like_number((SV*)cx->blk_loop.iterary) &&
1704 *SvPVX(cx->blk_loop.iterary) != '0'))
1706 if (SvNV(sv) < IV_MIN ||
1707 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1708 DIE(aTHX_ "Range iterator outside integer range");
1709 cx->blk_loop.iterix = SvIV(sv);
1710 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1713 cx->blk_loop.iterlval = newSVsv(sv);
1717 cx->blk_loop.iterary = PL_curstack;
1718 AvFILLp(PL_curstack) = SP - PL_stack_base;
1719 cx->blk_loop.iterix = MARK - PL_stack_base;
1728 register PERL_CONTEXT *cx;
1729 I32 gimme = GIMME_V;
1735 PUSHBLOCK(cx, CXt_LOOP, SP);
1736 PUSHLOOP(cx, 0, SP);
1744 register PERL_CONTEXT *cx;
1752 newsp = PL_stack_base + cx->blk_loop.resetsp;
1755 if (gimme == G_VOID)
1757 else if (gimme == G_SCALAR) {
1759 *++newsp = sv_mortalcopy(*SP);
1761 *++newsp = &PL_sv_undef;
1765 *++newsp = sv_mortalcopy(*++mark);
1766 TAINT_NOT; /* Each item is independent */
1772 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1773 PL_curpm = newpm; /* ... and pop $1 et al */
1785 register PERL_CONTEXT *cx;
1786 bool popsub2 = FALSE;
1793 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1794 if (cxstack_ix == PL_sortcxix
1795 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1797 if (cxstack_ix > PL_sortcxix)
1798 dounwind(PL_sortcxix);
1799 AvARRAY(PL_curstack)[1] = *SP;
1800 PL_stack_sp = PL_stack_base + 1;
1805 cxix = dopoptosub(cxstack_ix);
1807 DIE(aTHX_ "Can't return outside a subroutine");
1808 if (cxix < cxstack_ix)
1812 switch (CxTYPE(cx)) {
1818 if (AvFILLp(PL_comppad_name) >= 0)
1821 if (optype == OP_REQUIRE &&
1822 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1824 /* Unassume the success we assumed earlier. */
1825 SV *nsv = cx->blk_eval.old_namesv;
1826 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1827 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1834 DIE(aTHX_ "panic: return");
1838 if (gimme == G_SCALAR) {
1841 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1843 *++newsp = SvREFCNT_inc(*SP);
1848 *++newsp = sv_mortalcopy(*SP);
1851 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1853 *++newsp = sv_mortalcopy(*SP);
1855 *++newsp = &PL_sv_undef;
1857 else if (gimme == G_ARRAY) {
1858 while (++MARK <= SP) {
1859 *++newsp = (popsub2 && SvTEMP(*MARK))
1860 ? *MARK : sv_mortalcopy(*MARK);
1861 TAINT_NOT; /* Each item is independent */
1864 PL_stack_sp = newsp;
1866 /* Stack values are safe: */
1868 POPSUB(cx,sv); /* release CV and @_ ... */
1872 PL_curpm = newpm; /* ... and pop $1 et al */
1876 return pop_return();
1883 register PERL_CONTEXT *cx;
1893 if (PL_op->op_flags & OPf_SPECIAL) {
1894 cxix = dopoptoloop(cxstack_ix);
1896 DIE(aTHX_ "Can't \"last\" outside a loop block");
1899 cxix = dopoptolabel(cPVOP->op_pv);
1901 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1903 if (cxix < cxstack_ix)
1908 switch (CxTYPE(cx)) {
1911 newsp = PL_stack_base + cx->blk_loop.resetsp;
1912 nextop = cx->blk_loop.last_op->op_next;
1916 nextop = pop_return();
1920 nextop = pop_return();
1924 nextop = pop_return();
1927 DIE(aTHX_ "panic: last");
1931 if (gimme == G_SCALAR) {
1933 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1934 ? *SP : sv_mortalcopy(*SP);
1936 *++newsp = &PL_sv_undef;
1938 else if (gimme == G_ARRAY) {
1939 while (++MARK <= SP) {
1940 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1941 ? *MARK : sv_mortalcopy(*MARK);
1942 TAINT_NOT; /* Each item is independent */
1948 /* Stack values are safe: */
1951 POPLOOP(cx); /* release loop vars ... */
1955 POPSUB(cx,sv); /* release CV and @_ ... */
1958 PL_curpm = newpm; /* ... and pop $1 et al */
1968 register PERL_CONTEXT *cx;
1971 if (PL_op->op_flags & OPf_SPECIAL) {
1972 cxix = dopoptoloop(cxstack_ix);
1974 DIE(aTHX_ "Can't \"next\" outside a loop block");
1977 cxix = dopoptolabel(cPVOP->op_pv);
1979 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1981 if (cxix < cxstack_ix)
1986 /* clean scope, but only if there's no continue block */
1987 if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) {
1988 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1989 LEAVE_SCOPE(oldsave);
1991 return cx->blk_loop.next_op;
1997 register PERL_CONTEXT *cx;
2000 if (PL_op->op_flags & OPf_SPECIAL) {
2001 cxix = dopoptoloop(cxstack_ix);
2003 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2006 cxix = dopoptolabel(cPVOP->op_pv);
2008 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2010 if (cxix < cxstack_ix)
2014 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2015 LEAVE_SCOPE(oldsave);
2016 return cx->blk_loop.redo_op;
2020 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2024 static char too_deep[] = "Target of goto is too deeply nested";
2027 Perl_croak(aTHX_ too_deep);
2028 if (o->op_type == OP_LEAVE ||
2029 o->op_type == OP_SCOPE ||
2030 o->op_type == OP_LEAVELOOP ||
2031 o->op_type == OP_LEAVETRY)
2033 *ops++ = cUNOPo->op_first;
2035 Perl_croak(aTHX_ too_deep);
2038 if (o->op_flags & OPf_KIDS) {
2040 /* First try all the kids at this level, since that's likeliest. */
2041 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2042 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2043 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2046 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2047 if (kid == PL_lastgotoprobe)
2049 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2051 (ops[-1]->op_type != OP_NEXTSTATE &&
2052 ops[-1]->op_type != OP_DBSTATE)))
2054 if ((o = dofindlabel(kid, label, ops, oplimit)))
2073 register PERL_CONTEXT *cx;
2074 #define GOTO_DEPTH 64
2075 OP *enterops[GOTO_DEPTH];
2077 int do_dump = (PL_op->op_type == OP_DUMP);
2078 static char must_have_label[] = "goto must have label";
2081 if (PL_op->op_flags & OPf_STACKED) {
2085 /* This egregious kludge implements goto &subroutine */
2086 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2088 register PERL_CONTEXT *cx;
2089 CV* cv = (CV*)SvRV(sv);
2095 if (!CvROOT(cv) && !CvXSUB(cv)) {
2100 /* autoloaded stub? */
2101 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2103 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2104 GvNAMELEN(gv), FALSE);
2105 if (autogv && (cv = GvCV(autogv)))
2107 tmpstr = sv_newmortal();
2108 gv_efullname3(tmpstr, gv, Nullch);
2109 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2111 DIE(aTHX_ "Goto undefined subroutine");
2114 /* First do some returnish stuff. */
2115 cxix = dopoptosub(cxstack_ix);
2117 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2118 if (cxix < cxstack_ix)
2121 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2122 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2124 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2125 /* put @_ back onto stack */
2126 AV* av = cx->blk_sub.argarray;
2128 items = AvFILLp(av) + 1;
2130 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2131 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2132 PL_stack_sp += items;
2134 SvREFCNT_dec(GvAV(PL_defgv));
2135 GvAV(PL_defgv) = cx->blk_sub.savearray;
2136 #endif /* USE_THREADS */
2137 /* abandon @_ if it got reified */
2139 (void)sv_2mortal((SV*)av); /* delay until return */
2141 av_extend(av, items-1);
2142 AvFLAGS(av) = AVf_REIFY;
2143 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2146 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2149 av = (AV*)PL_curpad[0];
2151 av = GvAV(PL_defgv);
2153 items = AvFILLp(av) + 1;
2155 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2156 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2157 PL_stack_sp += items;
2159 if (CxTYPE(cx) == CXt_SUB &&
2160 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2161 SvREFCNT_dec(cx->blk_sub.cv);
2162 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2163 LEAVE_SCOPE(oldsave);
2165 /* Now do some callish stuff. */
2168 #ifdef PERL_XSUB_OLDSTYLE
2169 if (CvOLDSTYLE(cv)) {
2170 I32 (*fp3)(int,int,int);
2175 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2176 items = (*fp3)(CvXSUBANY(cv).any_i32,
2177 mark - PL_stack_base + 1,
2179 SP = PL_stack_base + items;
2182 #endif /* PERL_XSUB_OLDSTYLE */
2187 PL_stack_sp--; /* There is no cv arg. */
2188 /* Push a mark for the start of arglist */
2190 (void)(*CvXSUB(cv))(aTHXo_ cv);
2191 /* Pop the current context like a decent sub should */
2192 POPBLOCK(cx, PL_curpm);
2193 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2196 return pop_return();
2199 AV* padlist = CvPADLIST(cv);
2200 SV** svp = AvARRAY(padlist);
2201 if (CxTYPE(cx) == CXt_EVAL) {
2202 PL_in_eval = cx->blk_eval.old_in_eval;
2203 PL_eval_root = cx->blk_eval.old_eval_root;
2204 cx->cx_type = CXt_SUB;
2205 cx->blk_sub.hasargs = 0;
2207 cx->blk_sub.cv = cv;
2208 cx->blk_sub.olddepth = CvDEPTH(cv);
2210 if (CvDEPTH(cv) < 2)
2211 (void)SvREFCNT_inc(cv);
2212 else { /* save temporaries on recursion? */
2213 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2214 sub_crush_depth(cv);
2215 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2216 AV *newpad = newAV();
2217 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2218 I32 ix = AvFILLp((AV*)svp[1]);
2219 I32 names_fill = AvFILLp((AV*)svp[0]);
2220 svp = AvARRAY(svp[0]);
2221 for ( ;ix > 0; ix--) {
2222 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2223 char *name = SvPVX(svp[ix]);
2224 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2227 /* outer lexical or anon code */
2228 av_store(newpad, ix,
2229 SvREFCNT_inc(oldpad[ix]) );
2231 else { /* our own lexical */
2233 av_store(newpad, ix, sv = (SV*)newAV());
2234 else if (*name == '%')
2235 av_store(newpad, ix, sv = (SV*)newHV());
2237 av_store(newpad, ix, sv = NEWSV(0,0));
2241 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2242 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2245 av_store(newpad, ix, sv = NEWSV(0,0));
2249 if (cx->blk_sub.hasargs) {
2252 av_store(newpad, 0, (SV*)av);
2253 AvFLAGS(av) = AVf_REIFY;
2255 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2256 AvFILLp(padlist) = CvDEPTH(cv);
2257 svp = AvARRAY(padlist);
2261 if (!cx->blk_sub.hasargs) {
2262 AV* av = (AV*)PL_curpad[0];
2264 items = AvFILLp(av) + 1;
2266 /* Mark is at the end of the stack. */
2268 Copy(AvARRAY(av), SP + 1, items, SV*);
2273 #endif /* USE_THREADS */
2274 SAVEVPTR(PL_curpad);
2275 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2277 if (cx->blk_sub.hasargs)
2278 #endif /* USE_THREADS */
2280 AV* av = (AV*)PL_curpad[0];
2284 cx->blk_sub.savearray = GvAV(PL_defgv);
2285 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2286 #endif /* USE_THREADS */
2287 cx->blk_sub.argarray = av;
2290 if (items >= AvMAX(av) + 1) {
2292 if (AvARRAY(av) != ary) {
2293 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2294 SvPVX(av) = (char*)ary;
2296 if (items >= AvMAX(av) + 1) {
2297 AvMAX(av) = items - 1;
2298 Renew(ary,items+1,SV*);
2300 SvPVX(av) = (char*)ary;
2303 Copy(mark,AvARRAY(av),items,SV*);
2304 AvFILLp(av) = items - 1;
2305 assert(!AvREAL(av));
2312 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2314 * We do not care about using sv to call CV;
2315 * it's for informational purposes only.
2317 SV *sv = GvSV(PL_DBsub);
2320 if (PERLDB_SUB_NN) {
2321 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2324 gv_efullname3(sv, CvGV(cv), Nullch);
2327 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2328 PUSHMARK( PL_stack_sp );
2329 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2333 RETURNOP(CvSTART(cv));
2337 label = SvPV(sv,n_a);
2338 if (!(do_dump || *label))
2339 DIE(aTHX_ must_have_label);
2342 else if (PL_op->op_flags & OPf_SPECIAL) {
2344 DIE(aTHX_ must_have_label);
2347 label = cPVOP->op_pv;
2349 if (label && *label) {
2354 PL_lastgotoprobe = 0;
2356 for (ix = cxstack_ix; ix >= 0; ix--) {
2358 switch (CxTYPE(cx)) {
2360 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2363 gotoprobe = cx->blk_oldcop->op_sibling;
2369 gotoprobe = cx->blk_oldcop->op_sibling;
2371 gotoprobe = PL_main_root;
2374 if (CvDEPTH(cx->blk_sub.cv)) {
2375 gotoprobe = CvROOT(cx->blk_sub.cv);
2381 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2384 DIE(aTHX_ "panic: goto");
2385 gotoprobe = PL_main_root;
2389 retop = dofindlabel(gotoprobe, label,
2390 enterops, enterops + GOTO_DEPTH);
2394 PL_lastgotoprobe = gotoprobe;
2397 DIE(aTHX_ "Can't find label %s", label);
2399 /* pop unwanted frames */
2401 if (ix < cxstack_ix) {
2408 oldsave = PL_scopestack[PL_scopestack_ix];
2409 LEAVE_SCOPE(oldsave);
2412 /* push wanted frames */
2414 if (*enterops && enterops[1]) {
2416 for (ix = 1; enterops[ix]; ix++) {
2417 PL_op = enterops[ix];
2418 /* Eventually we may want to stack the needed arguments
2419 * for each op. For now, we punt on the hard ones. */
2420 if (PL_op->op_type == OP_ENTERITER)
2421 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2422 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2430 if (!retop) retop = PL_main_start;
2432 PL_restartop = retop;
2433 PL_do_undump = TRUE;
2437 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2438 PL_do_undump = FALSE;
2454 if (anum == 1 && VMSISH_EXIT)
2458 PL_exit_flags |= PERL_EXIT_EXPECTED;
2460 PUSHs(&PL_sv_undef);
2468 NV value = SvNVx(GvSV(cCOP->cop_gv));
2469 register I32 match = I_32(value);
2472 if (((NV)match) > value)
2473 --match; /* was fractional--truncate other way */
2475 match -= cCOP->uop.scop.scop_offset;
2478 else if (match > cCOP->uop.scop.scop_max)
2479 match = cCOP->uop.scop.scop_max;
2480 PL_op = cCOP->uop.scop.scop_next[match];
2490 PL_op = PL_op->op_next; /* can't assume anything */
2493 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2494 match -= cCOP->uop.scop.scop_offset;
2497 else if (match > cCOP->uop.scop.scop_max)
2498 match = cCOP->uop.scop.scop_max;
2499 PL_op = cCOP->uop.scop.scop_next[match];
2508 S_save_lines(pTHX_ AV *array, SV *sv)
2510 register char *s = SvPVX(sv);
2511 register char *send = SvPVX(sv) + SvCUR(sv);
2513 register I32 line = 1;
2515 while (s && s < send) {
2516 SV *tmpstr = NEWSV(85,0);
2518 sv_upgrade(tmpstr, SVt_PVMG);
2519 t = strchr(s, '\n');
2525 sv_setpvn(tmpstr, s, t - s);
2526 av_store(array, line++, tmpstr);
2531 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2533 S_docatch_body(pTHX_ va_list args)
2535 return docatch_body();
2540 S_docatch_body(pTHX)
2547 S_docatch(pTHX_ OP *o)
2552 volatile PERL_SI *cursi = PL_curstackinfo;
2556 assert(CATCH_GET == TRUE);
2559 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2561 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2567 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2573 if (PL_restartop && cursi == PL_curstackinfo) {
2574 PL_op = PL_restartop;
2591 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2592 /* sv Text to convert to OP tree. */
2593 /* startop op_free() this to undo. */
2594 /* code Short string id of the caller. */
2596 dSP; /* Make POPBLOCK work. */
2599 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2603 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2604 char *tmpbuf = tbuf;
2610 /* switch to eval mode */
2612 if (PL_curcop == &PL_compiling) {
2613 SAVECOPSTASH(&PL_compiling);
2614 CopSTASH_set(&PL_compiling, PL_curstash);
2616 SAVECOPFILE(&PL_compiling);
2617 SAVECOPLINE(&PL_compiling);
2618 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2619 SV *sv = sv_newmortal();
2620 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2621 code, (unsigned long)++PL_evalseq,
2622 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2626 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2627 CopFILE_set(&PL_compiling, tmpbuf+2);
2628 CopLINE_set(&PL_compiling, 1);
2629 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2630 deleting the eval's FILEGV from the stash before gv_check() runs
2631 (i.e. before run-time proper). To work around the coredump that
2632 ensues, we always turn GvMULTI_on for any globals that were
2633 introduced within evals. See force_ident(). GSAR 96-10-12 */
2634 safestr = savepv(tmpbuf);
2635 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2637 #ifdef OP_IN_REGISTER
2645 PL_op->op_type = OP_ENTEREVAL;
2646 PL_op->op_flags = 0; /* Avoid uninit warning. */
2647 PUSHBLOCK(cx, CXt_EVAL, SP);
2648 PUSHEVAL(cx, 0, Nullgv);
2649 rop = doeval(G_SCALAR, startop);
2650 POPBLOCK(cx,PL_curpm);
2653 (*startop)->op_type = OP_NULL;
2654 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2656 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2658 if (PL_curcop == &PL_compiling)
2659 PL_compiling.op_private = PL_hints;
2660 #ifdef OP_IN_REGISTER
2666 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2668 S_doeval(pTHX_ int gimme, OP** startop)
2676 PL_in_eval = EVAL_INEVAL;
2680 /* set up a scratch pad */
2683 SAVEVPTR(PL_curpad);
2684 SAVESPTR(PL_comppad);
2685 SAVESPTR(PL_comppad_name);
2686 SAVEI32(PL_comppad_name_fill);
2687 SAVEI32(PL_min_intro_pending);
2688 SAVEI32(PL_max_intro_pending);
2691 for (i = cxstack_ix - 1; i >= 0; i--) {
2692 PERL_CONTEXT *cx = &cxstack[i];
2693 if (CxTYPE(cx) == CXt_EVAL)
2695 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2696 caller = cx->blk_sub.cv;
2701 SAVESPTR(PL_compcv);
2702 PL_compcv = (CV*)NEWSV(1104,0);
2703 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2704 CvEVAL_on(PL_compcv);
2706 CvOWNER(PL_compcv) = 0;
2707 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2708 MUTEX_INIT(CvMUTEXP(PL_compcv));
2709 #endif /* USE_THREADS */
2711 PL_comppad = newAV();
2712 av_push(PL_comppad, Nullsv);
2713 PL_curpad = AvARRAY(PL_comppad);
2714 PL_comppad_name = newAV();
2715 PL_comppad_name_fill = 0;
2716 PL_min_intro_pending = 0;
2719 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2720 PL_curpad[0] = (SV*)newAV();
2721 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2722 #endif /* USE_THREADS */
2724 comppadlist = newAV();
2725 AvREAL_off(comppadlist);
2726 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2727 av_store(comppadlist, 1, (SV*)PL_comppad);
2728 CvPADLIST(PL_compcv) = comppadlist;
2731 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2733 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2736 SAVEFREESV(PL_compcv);
2738 /* make sure we compile in the right package */
2740 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2741 SAVESPTR(PL_curstash);
2742 PL_curstash = CopSTASH(PL_curcop);
2744 SAVESPTR(PL_beginav);
2745 PL_beginav = newAV();
2746 SAVEFREESV(PL_beginav);
2748 /* try to compile it */
2750 PL_eval_root = Nullop;
2752 PL_curcop = &PL_compiling;
2753 PL_curcop->cop_arybase = 0;
2754 SvREFCNT_dec(PL_rs);
2755 PL_rs = newSVpvn("\n", 1);
2756 if (saveop && saveop->op_flags & OPf_SPECIAL)
2757 PL_in_eval |= EVAL_KEEPERR;
2760 if (yyparse() || PL_error_count || !PL_eval_root) {
2764 I32 optype = 0; /* Might be reset by POPEVAL. */
2769 op_free(PL_eval_root);
2770 PL_eval_root = Nullop;
2772 SP = PL_stack_base + POPMARK; /* pop original mark */
2774 POPBLOCK(cx,PL_curpm);
2780 if (optype == OP_REQUIRE) {
2781 char* msg = SvPVx(ERRSV, n_a);
2782 DIE(aTHX_ "%sCompilation failed in require",
2783 *msg ? msg : "Unknown error\n");
2786 char* msg = SvPVx(ERRSV, n_a);
2788 POPBLOCK(cx,PL_curpm);
2790 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2791 (*msg ? msg : "Unknown error\n"));
2793 SvREFCNT_dec(PL_rs);
2794 PL_rs = SvREFCNT_inc(PL_nrs);
2796 MUTEX_LOCK(&PL_eval_mutex);
2798 COND_SIGNAL(&PL_eval_cond);
2799 MUTEX_UNLOCK(&PL_eval_mutex);
2800 #endif /* USE_THREADS */
2803 SvREFCNT_dec(PL_rs);
2804 PL_rs = SvREFCNT_inc(PL_nrs);
2805 CopLINE_set(&PL_compiling, 0);
2807 *startop = PL_eval_root;
2808 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2809 CvOUTSIDE(PL_compcv) = Nullcv;
2811 SAVEFREEOP(PL_eval_root);
2813 scalarvoid(PL_eval_root);
2814 else if (gimme & G_ARRAY)
2817 scalar(PL_eval_root);
2819 DEBUG_x(dump_eval());
2821 /* Register with debugger: */
2822 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2823 CV *cv = get_cv("DB::postponed", FALSE);
2827 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2829 call_sv((SV*)cv, G_DISCARD);
2833 /* compiled okay, so do it */
2835 CvDEPTH(PL_compcv) = 1;
2836 SP = PL_stack_base + POPMARK; /* pop original mark */
2837 PL_op = saveop; /* The caller may need it. */
2839 MUTEX_LOCK(&PL_eval_mutex);
2841 COND_SIGNAL(&PL_eval_cond);
2842 MUTEX_UNLOCK(&PL_eval_mutex);
2843 #endif /* USE_THREADS */
2845 RETURNOP(PL_eval_start);
2849 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2851 STRLEN namelen = strlen(name);
2854 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2855 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2856 char *pmc = SvPV_nolen(pmcsv);
2859 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2860 fp = PerlIO_open(name, mode);
2863 if (PerlLIO_stat(name, &pmstat) < 0 ||
2864 pmstat.st_mtime < pmcstat.st_mtime)
2866 fp = PerlIO_open(pmc, mode);
2869 fp = PerlIO_open(name, mode);
2872 SvREFCNT_dec(pmcsv);
2875 fp = PerlIO_open(name, mode);
2883 register PERL_CONTEXT *cx;
2888 SV *namesv = Nullsv;
2890 I32 gimme = G_SCALAR;
2891 PerlIO *tryrsfp = 0;
2893 int filter_has_file = 0;
2894 GV *filter_child_proc = 0;
2895 SV *filter_state = 0;
2901 if (SvPOKp(sv)) { /* require v5.6.1 */
2903 U8 *s = (U8*)SvPVX(sv);
2904 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2906 rev = utf8_to_uv(s, &len);
2909 ver = utf8_to_uv(s, &len);
2912 sver = utf8_to_uv(s, &len);
2921 if (PERL_REVISION < rev
2922 || (PERL_REVISION == rev
2923 && (PERL_VERSION < ver
2924 || (PERL_VERSION == ver
2925 && PERL_SUBVERSION < sver))))
2927 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2928 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2929 PERL_VERSION, PERL_SUBVERSION);
2932 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2933 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2934 + ((NV)PERL_SUBVERSION/(NV)1000000)
2935 + 0.00000099 < SvNV(sv))
2939 NV nver = (nrev - rev) * 1000;
2940 UV ver = (UV)(nver + 0.0009);
2941 NV nsver = (nver - ver) * 1000;
2942 UV sver = (UV)(nsver + 0.0009);
2944 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2945 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2946 PERL_VERSION, PERL_SUBVERSION);
2951 name = SvPV(sv, len);
2952 if (!(name && len > 0 && *name))
2953 DIE(aTHX_ "Null filename used");
2954 TAINT_PROPER("require");
2955 if (PL_op->op_type == OP_REQUIRE &&
2956 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2957 *svp != &PL_sv_undef)
2960 /* prepare to compile file */
2962 if (PERL_FILE_IS_ABSOLUTE(name)
2963 || (*name == '.' && (name[1] == '/' ||
2964 (name[1] == '.' && name[2] == '/'))))
2967 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2970 AV *ar = GvAVn(PL_incgv);
2974 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2977 namesv = NEWSV(806, 0);
2978 for (i = 0; i <= AvFILL(ar); i++) {
2979 SV *dirsv = *av_fetch(ar, i, TRUE);
2985 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2986 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2989 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2990 PTR2UV(SvANY(loader)), name);
2991 tryname = SvPVX(namesv);
3002 count = call_sv(loader, G_ARRAY);
3012 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3016 if (SvTYPE(arg) == SVt_PVGV) {
3017 IO *io = GvIO((GV *)arg);
3022 tryrsfp = IoIFP(io);
3023 if (IoTYPE(io) == '|') {
3024 /* reading from a child process doesn't
3025 nest -- when returning from reading
3026 the inner module, the outer one is
3027 unreadable (closed?) I've tried to
3028 save the gv to manage the lifespan of
3029 the pipe, but this didn't help. XXX */
3030 filter_child_proc = (GV *)arg;
3031 (void)SvREFCNT_inc(filter_child_proc);
3034 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3035 PerlIO_close(IoOFP(io));
3047 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3049 (void)SvREFCNT_inc(filter_sub);
3052 filter_state = SP[i];
3053 (void)SvREFCNT_inc(filter_state);
3057 tryrsfp = PerlIO_open("/dev/null",
3071 filter_has_file = 0;
3072 if (filter_child_proc) {
3073 SvREFCNT_dec(filter_child_proc);
3074 filter_child_proc = 0;
3077 SvREFCNT_dec(filter_state);
3081 SvREFCNT_dec(filter_sub);
3086 char *dir = SvPVx(dirsv, n_a);
3089 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3091 sv_setpv(namesv, unixdir);
3092 sv_catpv(namesv, unixname);
3094 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3096 TAINT_PROPER("require");
3097 tryname = SvPVX(namesv);
3098 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3100 if (tryname[0] == '.' && tryname[1] == '/')
3108 SAVECOPFILE(&PL_compiling);
3109 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3110 SvREFCNT_dec(namesv);
3112 if (PL_op->op_type == OP_REQUIRE) {
3113 char *msgstr = name;
3114 if (namesv) { /* did we lookup @INC? */
3115 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3116 SV *dirmsgsv = NEWSV(0, 0);
3117 AV *ar = GvAVn(PL_incgv);
3119 sv_catpvn(msg, " in @INC", 8);
3120 if (instr(SvPVX(msg), ".h "))
3121 sv_catpv(msg, " (change .h to .ph maybe?)");
3122 if (instr(SvPVX(msg), ".ph "))
3123 sv_catpv(msg, " (did you run h2ph?)");
3124 sv_catpv(msg, " (@INC contains:");
3125 for (i = 0; i <= AvFILL(ar); i++) {
3126 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3127 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3128 sv_catsv(msg, dirmsgsv);
3130 sv_catpvn(msg, ")", 1);
3131 SvREFCNT_dec(dirmsgsv);
3132 msgstr = SvPV_nolen(msg);
3134 DIE(aTHX_ "Can't locate %s", msgstr);
3140 SETERRNO(0, SS$_NORMAL);
3142 /* Assume success here to prevent recursive requirement. */
3143 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3144 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3148 lex_start(sv_2mortal(newSVpvn("",0)));
3149 SAVEGENERICSV(PL_rsfp_filters);
3150 PL_rsfp_filters = Nullav;
3155 SAVESPTR(PL_compiling.cop_warnings);
3156 if (PL_dowarn & G_WARN_ALL_ON)
3157 PL_compiling.cop_warnings = WARN_ALL ;
3158 else if (PL_dowarn & G_WARN_ALL_OFF)
3159 PL_compiling.cop_warnings = WARN_NONE ;
3161 PL_compiling.cop_warnings = WARN_STD ;
3163 if (filter_sub || filter_child_proc) {
3164 SV *datasv = filter_add(run_user_filter, Nullsv);
3165 IoLINES(datasv) = filter_has_file;
3166 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3167 IoTOP_GV(datasv) = (GV *)filter_state;
3168 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3171 /* switch to eval mode */
3172 push_return(PL_op->op_next);
3173 PUSHBLOCK(cx, CXt_EVAL, SP);
3174 PUSHEVAL(cx, name, Nullgv);
3176 SAVECOPLINE(&PL_compiling);
3177 CopLINE_set(&PL_compiling, 0);
3181 MUTEX_LOCK(&PL_eval_mutex);
3182 if (PL_eval_owner && PL_eval_owner != thr)
3183 while (PL_eval_owner)
3184 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3185 PL_eval_owner = thr;
3186 MUTEX_UNLOCK(&PL_eval_mutex);
3187 #endif /* USE_THREADS */
3188 return DOCATCH(doeval(G_SCALAR, NULL));
3193 return pp_require();
3199 register PERL_CONTEXT *cx;
3201 I32 gimme = GIMME_V, was = PL_sub_generation;
3202 char tbuf[TYPE_DIGITS(long) + 12];
3203 char *tmpbuf = tbuf;
3208 if (!SvPV(sv,len) || !len)
3210 TAINT_PROPER("eval");
3216 /* switch to eval mode */
3218 SAVECOPFILE(&PL_compiling);
3219 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3220 SV *sv = sv_newmortal();
3221 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3222 (unsigned long)++PL_evalseq,
3223 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3227 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3228 CopFILE_set(&PL_compiling, tmpbuf+2);
3229 CopLINE_set(&PL_compiling, 1);
3230 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3231 deleting the eval's FILEGV from the stash before gv_check() runs
3232 (i.e. before run-time proper). To work around the coredump that
3233 ensues, we always turn GvMULTI_on for any globals that were
3234 introduced within evals. See force_ident(). GSAR 96-10-12 */
3235 safestr = savepv(tmpbuf);
3236 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3238 PL_hints = PL_op->op_targ;
3239 SAVESPTR(PL_compiling.cop_warnings);
3240 if (!specialWARN(PL_compiling.cop_warnings)) {
3241 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3242 SAVEFREESV(PL_compiling.cop_warnings) ;
3245 push_return(PL_op->op_next);
3246 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3247 PUSHEVAL(cx, 0, Nullgv);
3249 /* prepare to compile string */
3251 if (PERLDB_LINE && PL_curstash != PL_debstash)
3252 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3255 MUTEX_LOCK(&PL_eval_mutex);
3256 if (PL_eval_owner && PL_eval_owner != thr)
3257 while (PL_eval_owner)
3258 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3259 PL_eval_owner = thr;
3260 MUTEX_UNLOCK(&PL_eval_mutex);
3261 #endif /* USE_THREADS */
3262 ret = doeval(gimme, NULL);
3263 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3264 && ret != PL_op->op_next) { /* Successive compilation. */
3265 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3267 return DOCATCH(ret);
3277 register PERL_CONTEXT *cx;
3279 U8 save_flags = PL_op -> op_flags;
3284 retop = pop_return();
3287 if (gimme == G_VOID)
3289 else if (gimme == G_SCALAR) {
3292 if (SvFLAGS(TOPs) & SVs_TEMP)
3295 *MARK = sv_mortalcopy(TOPs);
3299 *MARK = &PL_sv_undef;
3304 /* in case LEAVE wipes old return values */
3305 for (mark = newsp + 1; mark <= SP; mark++) {
3306 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3307 *mark = sv_mortalcopy(*mark);
3308 TAINT_NOT; /* Each item is independent */
3312 PL_curpm = newpm; /* Don't pop $1 et al till now */
3314 if (AvFILLp(PL_comppad_name) >= 0)
3318 assert(CvDEPTH(PL_compcv) == 1);
3320 CvDEPTH(PL_compcv) = 0;
3323 if (optype == OP_REQUIRE &&
3324 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3326 /* Unassume the success we assumed earlier. */
3327 SV *nsv = cx->blk_eval.old_namesv;
3328 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3329 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3330 /* die_where() did LEAVE, or we won't be here */
3334 if (!(save_flags & OPf_SPECIAL))
3344 register PERL_CONTEXT *cx;
3345 I32 gimme = GIMME_V;
3350 push_return(cLOGOP->op_other->op_next);
3351 PUSHBLOCK(cx, CXt_EVAL, SP);
3353 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3355 PL_in_eval = EVAL_INEVAL;
3358 return DOCATCH(PL_op->op_next);
3368 register PERL_CONTEXT *cx;
3376 if (gimme == G_VOID)
3378 else if (gimme == G_SCALAR) {
3381 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3384 *MARK = sv_mortalcopy(TOPs);
3388 *MARK = &PL_sv_undef;
3393 /* in case LEAVE wipes old return values */
3394 for (mark = newsp + 1; mark <= SP; mark++) {
3395 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3396 *mark = sv_mortalcopy(*mark);
3397 TAINT_NOT; /* Each item is independent */
3401 PL_curpm = newpm; /* Don't pop $1 et al till now */
3409 S_doparseform(pTHX_ SV *sv)
3412 register char *s = SvPV_force(sv, len);
3413 register char *send = s + len;
3414 register char *base;
3415 register I32 skipspaces = 0;
3418 bool postspace = FALSE;
3426 Perl_croak(aTHX_ "Null picture in formline");
3428 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3433 *fpc++ = FF_LINEMARK;
3434 noblank = repeat = FALSE;
3452 case ' ': case '\t':
3463 *fpc++ = FF_LITERAL;
3471 *fpc++ = skipspaces;
3475 *fpc++ = FF_NEWLINE;
3479 arg = fpc - linepc + 1;
3486 *fpc++ = FF_LINEMARK;
3487 noblank = repeat = FALSE;
3496 ischop = s[-1] == '^';
3502 arg = (s - base) - 1;
3504 *fpc++ = FF_LITERAL;
3513 *fpc++ = FF_LINEGLOB;
3515 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3516 arg = ischop ? 512 : 0;
3526 arg |= 256 + (s - f);
3528 *fpc++ = s - base; /* fieldsize for FETCH */
3529 *fpc++ = FF_DECIMAL;
3534 bool ismore = FALSE;
3537 while (*++s == '>') ;
3538 prespace = FF_SPACE;
3540 else if (*s == '|') {
3541 while (*++s == '|') ;
3542 prespace = FF_HALFSPACE;
3547 while (*++s == '<') ;
3550 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3554 *fpc++ = s - base; /* fieldsize for FETCH */
3556 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3574 { /* need to jump to the next word */
3576 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3577 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3578 s = SvPVX(sv) + SvCUR(sv) + z;
3580 Copy(fops, s, arg, U16);
3582 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3587 * The rest of this file was derived from source code contributed
3590 * NOTE: this code was derived from Tom Horsley's qsort replacement
3591 * and should not be confused with the original code.
3594 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3596 Permission granted to distribute under the same terms as perl which are
3599 This program is free software; you can redistribute it and/or modify
3600 it under the terms of either:
3602 a) the GNU General Public License as published by the Free
3603 Software Foundation; either version 1, or (at your option) any
3606 b) the "Artistic License" which comes with this Kit.
3608 Details on the perl license can be found in the perl source code which
3609 may be located via the www.perl.com web page.
3611 This is the most wonderfulest possible qsort I can come up with (and
3612 still be mostly portable) My (limited) tests indicate it consistently
3613 does about 20% fewer calls to compare than does the qsort in the Visual
3614 C++ library, other vendors may vary.
3616 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3617 others I invented myself (or more likely re-invented since they seemed
3618 pretty obvious once I watched the algorithm operate for a while).
3620 Most of this code was written while watching the Marlins sweep the Giants
3621 in the 1997 National League Playoffs - no Braves fans allowed to use this
3622 code (just kidding :-).
3624 I realize that if I wanted to be true to the perl tradition, the only
3625 comment in this file would be something like:
3627 ...they shuffled back towards the rear of the line. 'No, not at the
3628 rear!' the slave-driver shouted. 'Three files up. And stay there...
3630 However, I really needed to violate that tradition just so I could keep
3631 track of what happens myself, not to mention some poor fool trying to
3632 understand this years from now :-).
3635 /* ********************************************************** Configuration */
3637 #ifndef QSORT_ORDER_GUESS
3638 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3641 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3642 future processing - a good max upper bound is log base 2 of memory size
3643 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3644 safely be smaller than that since the program is taking up some space and
3645 most operating systems only let you grab some subset of contiguous
3646 memory (not to mention that you are normally sorting data larger than
3647 1 byte element size :-).
3649 #ifndef QSORT_MAX_STACK
3650 #define QSORT_MAX_STACK 32
3653 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3654 Anything bigger and we use qsort. If you make this too small, the qsort
3655 will probably break (or become less efficient), because it doesn't expect
3656 the middle element of a partition to be the same as the right or left -
3657 you have been warned).
3659 #ifndef QSORT_BREAK_EVEN
3660 #define QSORT_BREAK_EVEN 6
3663 /* ************************************************************* Data Types */
3665 /* hold left and right index values of a partition waiting to be sorted (the
3666 partition includes both left and right - right is NOT one past the end or
3667 anything like that).
3669 struct partition_stack_entry {
3672 #ifdef QSORT_ORDER_GUESS
3673 int qsort_break_even;
3677 /* ******************************************************* Shorthand Macros */
3679 /* Note that these macros will be used from inside the qsort function where
3680 we happen to know that the variable 'elt_size' contains the size of an
3681 array element and the variable 'temp' points to enough space to hold a
3682 temp element and the variable 'array' points to the array being sorted
3683 and 'compare' is the pointer to the compare routine.
3685 Also note that there are very many highly architecture specific ways
3686 these might be sped up, but this is simply the most generally portable
3687 code I could think of.
3690 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3692 #define qsort_cmp(elt1, elt2) \
3693 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3695 #ifdef QSORT_ORDER_GUESS
3696 #define QSORT_NOTICE_SWAP swapped++;
3698 #define QSORT_NOTICE_SWAP
3701 /* swaps contents of array elements elt1, elt2.
3703 #define qsort_swap(elt1, elt2) \
3706 temp = array[elt1]; \
3707 array[elt1] = array[elt2]; \
3708 array[elt2] = temp; \
3711 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3712 elt3 and elt3 gets elt1.
3714 #define qsort_rotate(elt1, elt2, elt3) \
3717 temp = array[elt1]; \
3718 array[elt1] = array[elt2]; \
3719 array[elt2] = array[elt3]; \
3720 array[elt3] = temp; \
3723 /* ************************************************************ Debug stuff */
3730 return; /* good place to set a breakpoint */
3733 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3736 doqsort_all_asserts(
3740 int (*compare)(const void * elt1, const void * elt2),
3741 int pc_left, int pc_right, int u_left, int u_right)
3745 qsort_assert(pc_left <= pc_right);
3746 qsort_assert(u_right < pc_left);
3747 qsort_assert(pc_right < u_left);
3748 for (i = u_right + 1; i < pc_left; ++i) {
3749 qsort_assert(qsort_cmp(i, pc_left) < 0);
3751 for (i = pc_left; i < pc_right; ++i) {
3752 qsort_assert(qsort_cmp(i, pc_right) == 0);
3754 for (i = pc_right + 1; i < u_left; ++i) {
3755 qsort_assert(qsort_cmp(pc_right, i) < 0);
3759 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3760 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3761 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3765 #define qsort_assert(t) ((void)0)
3767 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3771 /* ****************************************************************** qsort */
3774 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3778 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3779 int next_stack_entry = 0;
3783 #ifdef QSORT_ORDER_GUESS
3784 int qsort_break_even;
3788 /* Make sure we actually have work to do.
3790 if (num_elts <= 1) {
3794 /* Setup the initial partition definition and fall into the sorting loop
3797 part_right = (int)(num_elts - 1);
3798 #ifdef QSORT_ORDER_GUESS
3799 qsort_break_even = QSORT_BREAK_EVEN;
3801 #define qsort_break_even QSORT_BREAK_EVEN
3804 if ((part_right - part_left) >= qsort_break_even) {
3805 /* OK, this is gonna get hairy, so lets try to document all the
3806 concepts and abbreviations and variables and what they keep
3809 pc: pivot chunk - the set of array elements we accumulate in the
3810 middle of the partition, all equal in value to the original
3811 pivot element selected. The pc is defined by:
3813 pc_left - the leftmost array index of the pc
3814 pc_right - the rightmost array index of the pc
3816 we start with pc_left == pc_right and only one element
3817 in the pivot chunk (but it can grow during the scan).
3819 u: uncompared elements - the set of elements in the partition
3820 we have not yet compared to the pivot value. There are two
3821 uncompared sets during the scan - one to the left of the pc
3822 and one to the right.
3824 u_right - the rightmost index of the left side's uncompared set
3825 u_left - the leftmost index of the right side's uncompared set
3827 The leftmost index of the left sides's uncompared set
3828 doesn't need its own variable because it is always defined
3829 by the leftmost edge of the whole partition (part_left). The
3830 same goes for the rightmost edge of the right partition
3833 We know there are no uncompared elements on the left once we
3834 get u_right < part_left and no uncompared elements on the
3835 right once u_left > part_right. When both these conditions
3836 are met, we have completed the scan of the partition.
3838 Any elements which are between the pivot chunk and the
3839 uncompared elements should be less than the pivot value on
3840 the left side and greater than the pivot value on the right
3841 side (in fact, the goal of the whole algorithm is to arrange
3842 for that to be true and make the groups of less-than and
3843 greater-then elements into new partitions to sort again).
3845 As you marvel at the complexity of the code and wonder why it
3846 has to be so confusing. Consider some of the things this level
3847 of confusion brings:
3849 Once I do a compare, I squeeze every ounce of juice out of it. I
3850 never do compare calls I don't have to do, and I certainly never
3853 I also never swap any elements unless I can prove there is a
3854 good reason. Many sort algorithms will swap a known value with
3855 an uncompared value just to get things in the right place (or
3856 avoid complexity :-), but that uncompared value, once it gets
3857 compared, may then have to be swapped again. A lot of the
3858 complexity of this code is due to the fact that it never swaps
3859 anything except compared values, and it only swaps them when the
3860 compare shows they are out of position.
3862 int pc_left, pc_right;
3863 int u_right, u_left;
3867 pc_left = ((part_left + part_right) / 2);
3869 u_right = pc_left - 1;
3870 u_left = pc_right + 1;
3872 /* Qsort works best when the pivot value is also the median value
3873 in the partition (unfortunately you can't find the median value
3874 without first sorting :-), so to give the algorithm a helping
3875 hand, we pick 3 elements and sort them and use the median value
3876 of that tiny set as the pivot value.
3878 Some versions of qsort like to use the left middle and right as
3879 the 3 elements to sort so they can insure the ends of the
3880 partition will contain values which will stop the scan in the
3881 compare loop, but when you have to call an arbitrarily complex
3882 routine to do a compare, its really better to just keep track of
3883 array index values to know when you hit the edge of the
3884 partition and avoid the extra compare. An even better reason to
3885 avoid using a compare call is the fact that you can drop off the
3886 edge of the array if someone foolishly provides you with an
3887 unstable compare function that doesn't always provide consistent
3890 So, since it is simpler for us to compare the three adjacent
3891 elements in the middle of the partition, those are the ones we
3892 pick here (conveniently pointed at by u_right, pc_left, and
3893 u_left). The values of the left, center, and right elements
3894 are refered to as l c and r in the following comments.
3897 #ifdef QSORT_ORDER_GUESS
3900 s = qsort_cmp(u_right, pc_left);
3903 s = qsort_cmp(pc_left, u_left);
3904 /* if l < c, c < r - already in order - nothing to do */
3906 /* l < c, c == r - already in order, pc grows */
3908 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3910 /* l < c, c > r - need to know more */
3911 s = qsort_cmp(u_right, u_left);
3913 /* l < c, c > r, l < r - swap c & r to get ordered */
3914 qsort_swap(pc_left, u_left);
3915 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3916 } else if (s == 0) {
3917 /* l < c, c > r, l == r - swap c&r, grow pc */
3918 qsort_swap(pc_left, u_left);
3920 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3922 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3923 qsort_rotate(pc_left, u_right, u_left);
3924 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3927 } else if (s == 0) {
3929 s = qsort_cmp(pc_left, u_left);
3931 /* l == c, c < r - already in order, grow pc */
3933 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3934 } else if (s == 0) {
3935 /* l == c, c == r - already in order, grow pc both ways */
3938 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3940 /* l == c, c > r - swap l & r, grow pc */
3941 qsort_swap(u_right, u_left);
3943 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3947 s = qsort_cmp(pc_left, u_left);
3949 /* l > c, c < r - need to know more */
3950 s = qsort_cmp(u_right, u_left);
3952 /* l > c, c < r, l < r - swap l & c to get ordered */
3953 qsort_swap(u_right, pc_left);
3954 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3955 } else if (s == 0) {
3956 /* l > c, c < r, l == r - swap l & c, grow pc */
3957 qsort_swap(u_right, pc_left);
3959 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3961 /* l > c, c < r, l > r - rotate lcr into crl to order */
3962 qsort_rotate(u_right, pc_left, u_left);
3963 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3965 } else if (s == 0) {
3966 /* l > c, c == r - swap ends, grow pc */
3967 qsort_swap(u_right, u_left);
3969 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3971 /* l > c, c > r - swap ends to get in order */
3972 qsort_swap(u_right, u_left);
3973 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3976 /* We now know the 3 middle elements have been compared and
3977 arranged in the desired order, so we can shrink the uncompared
3982 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3984 /* The above massive nested if was the simple part :-). We now have
3985 the middle 3 elements ordered and we need to scan through the
3986 uncompared sets on either side, swapping elements that are on
3987 the wrong side or simply shuffling equal elements around to get
3988 all equal elements into the pivot chunk.
3992 int still_work_on_left;
3993 int still_work_on_right;
3995 /* Scan the uncompared values on the left. If I find a value
3996 equal to the pivot value, move it over so it is adjacent to
3997 the pivot chunk and expand the pivot chunk. If I find a value
3998 less than the pivot value, then just leave it - its already
3999 on the correct side of the partition. If I find a greater
4000 value, then stop the scan.
4002 while ((still_work_on_left = (u_right >= part_left))) {
4003 s = qsort_cmp(u_right, pc_left);
4006 } else if (s == 0) {
4008 if (pc_left != u_right) {
4009 qsort_swap(u_right, pc_left);
4015 qsort_assert(u_right < pc_left);
4016 qsort_assert(pc_left <= pc_right);
4017 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4018 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4021 /* Do a mirror image scan of uncompared values on the right
4023 while ((still_work_on_right = (u_left <= part_right))) {
4024 s = qsort_cmp(pc_right, u_left);
4027 } else if (s == 0) {
4029 if (pc_right != u_left) {
4030 qsort_swap(pc_right, u_left);
4036 qsort_assert(u_left > pc_right);
4037 qsort_assert(pc_left <= pc_right);
4038 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4039 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4042 if (still_work_on_left) {
4043 /* I know I have a value on the left side which needs to be
4044 on the right side, but I need to know more to decide
4045 exactly the best thing to do with it.
4047 if (still_work_on_right) {
4048 /* I know I have values on both side which are out of
4049 position. This is a big win because I kill two birds
4050 with one swap (so to speak). I can advance the
4051 uncompared pointers on both sides after swapping both
4052 of them into the right place.
4054 qsort_swap(u_right, u_left);
4057 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4059 /* I have an out of position value on the left, but the
4060 right is fully scanned, so I "slide" the pivot chunk
4061 and any less-than values left one to make room for the
4062 greater value over on the right. If the out of position
4063 value is immediately adjacent to the pivot chunk (there
4064 are no less-than values), I can do that with a swap,
4065 otherwise, I have to rotate one of the less than values
4066 into the former position of the out of position value
4067 and the right end of the pivot chunk into the left end
4071 if (pc_left == u_right) {
4072 qsort_swap(u_right, pc_right);
4073 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4075 qsort_rotate(u_right, pc_left, pc_right);
4076 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4081 } else if (still_work_on_right) {
4082 /* Mirror image of complex case above: I have an out of
4083 position value on the right, but the left is fully
4084 scanned, so I need to shuffle things around to make room
4085 for the right value on the left.
4088 if (pc_right == u_left) {
4089 qsort_swap(u_left, pc_left);
4090 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4092 qsort_rotate(pc_right, pc_left, u_left);
4093 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4098 /* No more scanning required on either side of partition,
4099 break out of loop and figure out next set of partitions
4105 /* The elements in the pivot chunk are now in the right place. They
4106 will never move or be compared again. All I have to do is decide
4107 what to do with the stuff to the left and right of the pivot
4110 Notes on the QSORT_ORDER_GUESS ifdef code:
4112 1. If I just built these partitions without swapping any (or
4113 very many) elements, there is a chance that the elements are
4114 already ordered properly (being properly ordered will
4115 certainly result in no swapping, but the converse can't be
4118 2. A (properly written) insertion sort will run faster on
4119 already ordered data than qsort will.
4121 3. Perhaps there is some way to make a good guess about
4122 switching to an insertion sort earlier than partition size 6
4123 (for instance - we could save the partition size on the stack
4124 and increase the size each time we find we didn't swap, thus
4125 switching to insertion sort earlier for partitions with a
4126 history of not swapping).
4128 4. Naturally, if I just switch right away, it will make
4129 artificial benchmarks with pure ascending (or descending)
4130 data look really good, but is that a good reason in general?
4134 #ifdef QSORT_ORDER_GUESS
4136 #if QSORT_ORDER_GUESS == 1
4137 qsort_break_even = (part_right - part_left) + 1;
4139 #if QSORT_ORDER_GUESS == 2
4140 qsort_break_even *= 2;
4142 #if QSORT_ORDER_GUESS == 3
4143 int prev_break = qsort_break_even;
4144 qsort_break_even *= qsort_break_even;
4145 if (qsort_break_even < prev_break) {
4146 qsort_break_even = (part_right - part_left) + 1;
4150 qsort_break_even = QSORT_BREAK_EVEN;
4154 if (part_left < pc_left) {
4155 /* There are elements on the left which need more processing.
4156 Check the right as well before deciding what to do.
4158 if (pc_right < part_right) {
4159 /* We have two partitions to be sorted. Stack the biggest one
4160 and process the smallest one on the next iteration. This
4161 minimizes the stack height by insuring that any additional
4162 stack entries must come from the smallest partition which
4163 (because it is smallest) will have the fewest
4164 opportunities to generate additional stack entries.
4166 if ((part_right - pc_right) > (pc_left - part_left)) {
4167 /* stack the right partition, process the left */
4168 partition_stack[next_stack_entry].left = pc_right + 1;
4169 partition_stack[next_stack_entry].right = part_right;
4170 #ifdef QSORT_ORDER_GUESS
4171 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4173 part_right = pc_left - 1;
4175 /* stack the left partition, process the right */
4176 partition_stack[next_stack_entry].left = part_left;
4177 partition_stack[next_stack_entry].right = pc_left - 1;
4178 #ifdef QSORT_ORDER_GUESS
4179 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4181 part_left = pc_right + 1;
4183 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4186 /* The elements on the left are the only remaining elements
4187 that need sorting, arrange for them to be processed as the
4190 part_right = pc_left - 1;
4192 } else if (pc_right < part_right) {
4193 /* There is only one chunk on the right to be sorted, make it
4194 the new partition and loop back around.
4196 part_left = pc_right + 1;
4198 /* This whole partition wound up in the pivot chunk, so
4199 we need to get a new partition off the stack.
4201 if (next_stack_entry == 0) {
4202 /* the stack is empty - we are done */
4206 part_left = partition_stack[next_stack_entry].left;
4207 part_right = partition_stack[next_stack_entry].right;
4208 #ifdef QSORT_ORDER_GUESS
4209 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4213 /* This partition is too small to fool with qsort complexity, just
4214 do an ordinary insertion sort to minimize overhead.
4217 /* Assume 1st element is in right place already, and start checking
4218 at 2nd element to see where it should be inserted.
4220 for (i = part_left + 1; i <= part_right; ++i) {
4222 /* Scan (backwards - just in case 'i' is already in right place)
4223 through the elements already sorted to see if the ith element
4224 belongs ahead of one of them.
4226 for (j = i - 1; j >= part_left; --j) {
4227 if (qsort_cmp(i, j) >= 0) {
4228 /* i belongs right after j
4235 /* Looks like we really need to move some things
4239 for (k = i - 1; k >= j; --k)
4240 array[k + 1] = array[k];
4245 /* That partition is now sorted, grab the next one, or get out
4246 of the loop if there aren't any more.
4249 if (next_stack_entry == 0) {
4250 /* the stack is empty - we are done */
4254 part_left = partition_stack[next_stack_entry].left;
4255 part_right = partition_stack[next_stack_entry].right;
4256 #ifdef QSORT_ORDER_GUESS
4257 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4262 /* Believe it or not, the array is sorted at this point! */
4274 sortcv(pTHXo_ SV *a, SV *b)
4277 I32 oldsaveix = PL_savestack_ix;
4278 I32 oldscopeix = PL_scopestack_ix;
4280 GvSV(PL_firstgv) = a;
4281 GvSV(PL_secondgv) = b;
4282 PL_stack_sp = PL_stack_base;
4285 if (PL_stack_sp != PL_stack_base + 1)
4286 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4287 if (!SvNIOKp(*PL_stack_sp))
4288 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4289 result = SvIV(*PL_stack_sp);
4290 while (PL_scopestack_ix > oldscopeix) {
4293 leave_scope(oldsaveix);
4298 sortcv_stacked(pTHXo_ SV *a, SV *b)
4301 I32 oldsaveix = PL_savestack_ix;
4302 I32 oldscopeix = PL_scopestack_ix;
4307 av = (AV*)PL_curpad[0];
4309 av = GvAV(PL_defgv);
4312 if (AvMAX(av) < 1) {
4313 SV** ary = AvALLOC(av);
4314 if (AvARRAY(av) != ary) {
4315 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4316 SvPVX(av) = (char*)ary;
4318 if (AvMAX(av) < 1) {
4321 SvPVX(av) = (char*)ary;
4328 PL_stack_sp = PL_stack_base;
4331 if (PL_stack_sp != PL_stack_base + 1)
4332 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4333 if (!SvNIOKp(*PL_stack_sp))
4334 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4335 result = SvIV(*PL_stack_sp);
4336 while (PL_scopestack_ix > oldscopeix) {
4339 leave_scope(oldsaveix);
4344 sortcv_xsub(pTHXo_ SV *a, SV *b)
4347 I32 oldsaveix = PL_savestack_ix;
4348 I32 oldscopeix = PL_scopestack_ix;
4350 CV *cv=(CV*)PL_sortcop;
4358 (void)(*CvXSUB(cv))(aTHXo_ cv);
4359 if (PL_stack_sp != PL_stack_base + 1)
4360 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4361 if (!SvNIOKp(*PL_stack_sp))
4362 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4363 result = SvIV(*PL_stack_sp);
4364 while (PL_scopestack_ix > oldscopeix) {
4367 leave_scope(oldsaveix);
4373 sv_ncmp(pTHXo_ SV *a, SV *b)
4377 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4381 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4385 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4387 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4389 if (PL_amagic_generation) { \
4390 if (SvAMAGIC(left)||SvAMAGIC(right))\
4391 *svp = amagic_call(left, \
4399 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4402 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4407 I32 i = SvIVX(tmpsv);
4417 return sv_ncmp(aTHXo_ a, b);
4421 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4424 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4429 I32 i = SvIVX(tmpsv);
4439 return sv_i_ncmp(aTHXo_ a, b);
4443 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4446 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4451 I32 i = SvIVX(tmpsv);
4461 return sv_cmp(str1, str2);
4465 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4468 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4473 I32 i = SvIVX(tmpsv);
4483 return sv_cmp_locale(str1, str2);
4487 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4489 SV *datasv = FILTER_DATA(idx);
4490 int filter_has_file = IoLINES(datasv);
4491 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4492 SV *filter_state = (SV *)IoTOP_GV(datasv);
4493 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4496 /* I was having segfault trouble under Linux 2.2.5 after a
4497 parse error occured. (Had to hack around it with a test
4498 for PL_error_count == 0.) Solaris doesn't segfault --
4499 not sure where the trouble is yet. XXX */
4501 if (filter_has_file) {
4502 len = FILTER_READ(idx+1, buf_sv, maxlen);
4505 if (filter_sub && len >= 0) {
4516 PUSHs(sv_2mortal(newSViv(maxlen)));
4518 PUSHs(filter_state);
4521 count = call_sv(filter_sub, G_SCALAR);
4537 IoLINES(datasv) = 0;
4538 if (filter_child_proc) {
4539 SvREFCNT_dec(filter_child_proc);
4540 IoFMT_GV(datasv) = Nullgv;
4543 SvREFCNT_dec(filter_state);
4544 IoTOP_GV(datasv) = Nullgv;
4547 SvREFCNT_dec(filter_sub);
4548 IoBOTTOM_GV(datasv) = Nullgv;
4550 filter_del(run_user_filter);
4559 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4561 return sv_cmp_locale(str1, str2);
4565 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4567 return sv_cmp(str1, str2);
4570 #endif /* PERL_OBJECT */