3 * Copyright (c) 1991-2001, 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_DYN_UTF8;
120 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
121 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
122 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
123 inside tie/overload accessors. */
127 #ifndef INCOMPLETE_TAINTS
130 pm->op_pmdynflags |= PMdf_TAINTED;
132 pm->op_pmdynflags &= ~PMdf_TAINTED;
136 if (!pm->op_pmregexp->prelen && PL_curpm)
138 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
139 pm->op_pmflags |= PMf_WHITE;
141 /* XXX runtime compiled output needs to move to the pad */
142 if (pm->op_pmflags & PMf_KEEP) {
143 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
144 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
145 /* XXX can't change the optree at runtime either */
146 cLOGOP->op_first->op_next = PL_op->op_next;
155 register PMOP *pm = (PMOP*) cLOGOP->op_other;
156 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
157 register SV *dstr = cx->sb_dstr;
158 register char *s = cx->sb_s;
159 register char *m = cx->sb_m;
160 char *orig = cx->sb_orig;
161 register REGEXP *rx = cx->sb_rx;
163 rxres_restore(&cx->sb_rxres, rx);
165 if (cx->sb_iters++) {
166 if (cx->sb_iters > cx->sb_maxiters)
167 DIE(aTHX_ "Substitution loop");
169 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
170 cx->sb_rxtainted |= 2;
171 sv_catsv(dstr, POPs);
174 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
175 s == m, cx->sb_targ, NULL,
176 ((cx->sb_rflags & REXEC_COPY_STR)
177 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
178 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
180 SV *targ = cx->sb_targ;
182 sv_catpvn(dstr, s, cx->sb_strend - s);
183 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
185 (void)SvOOK_off(targ);
186 Safefree(SvPVX(targ));
187 SvPVX(targ) = SvPVX(dstr);
188 SvCUR_set(targ, SvCUR(dstr));
189 SvLEN_set(targ, SvLEN(dstr));
195 TAINT_IF(cx->sb_rxtainted & 1);
196 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
198 (void)SvPOK_only_UTF8(targ);
199 TAINT_IF(cx->sb_rxtainted);
203 LEAVE_SCOPE(cx->sb_oldsave);
205 RETURNOP(pm->op_next);
208 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
211 cx->sb_orig = orig = rx->subbeg;
213 cx->sb_strend = s + (cx->sb_strend - m);
215 cx->sb_m = m = rx->startp[0] + orig;
217 sv_catpvn(dstr, s, m-s);
218 cx->sb_s = rx->endp[0] + orig;
219 { /* Update the pos() information. */
220 SV *sv = cx->sb_targ;
223 if (SvTYPE(sv) < SVt_PVMG)
224 SvUPGRADE(sv, SVt_PVMG);
225 if (!(mg = mg_find(sv, 'g'))) {
226 sv_magic(sv, Nullsv, 'g', Nullch, 0);
227 mg = mg_find(sv, 'g');
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
235 rxres_save(&cx->sb_rxres, rx);
236 RETURNOP(pm->op_pmreplstart);
240 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
245 if (!p || p[1] < rx->nparens) {
246 i = 6 + rx->nparens * 2;
254 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
255 RX_MATCH_COPIED_off(rx);
259 *p++ = PTR2UV(rx->subbeg);
260 *p++ = (UV)rx->sublen;
261 for (i = 0; i <= rx->nparens; ++i) {
262 *p++ = (UV)rx->startp[i];
263 *p++ = (UV)rx->endp[i];
268 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
273 if (RX_MATCH_COPIED(rx))
274 Safefree(rx->subbeg);
275 RX_MATCH_COPIED_set(rx, *p);
280 rx->subbeg = INT2PTR(char*,*p++);
281 rx->sublen = (I32)(*p++);
282 for (i = 0; i <= rx->nparens; ++i) {
283 rx->startp[i] = (I32)(*p++);
284 rx->endp[i] = (I32)(*p++);
289 Perl_rxres_free(pTHX_ void **rsp)
294 Safefree(INT2PTR(char*,*p));
302 djSP; dMARK; dORIGMARK;
303 register SV *tmpForm = *++MARK;
315 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
321 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
322 bool item_is_utf = FALSE;
324 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
325 if (SvREADONLY(tmpForm)) {
326 SvREADONLY_off(tmpForm);
327 doparseform(tmpForm);
328 SvREADONLY_on(tmpForm);
331 doparseform(tmpForm);
334 SvPV_force(PL_formtarget, len);
335 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
337 f = SvPV(tmpForm, len);
338 /* need to jump to the next word */
339 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
348 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
349 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
350 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
351 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
352 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
354 case FF_CHECKNL: name = "CHECKNL"; break;
355 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
356 case FF_SPACE: name = "SPACE"; break;
357 case FF_HALFSPACE: name = "HALFSPACE"; break;
358 case FF_ITEM: name = "ITEM"; break;
359 case FF_CHOP: name = "CHOP"; break;
360 case FF_LINEGLOB: name = "LINEGLOB"; break;
361 case FF_NEWLINE: name = "NEWLINE"; break;
362 case FF_MORE: name = "MORE"; break;
363 case FF_LINEMARK: name = "LINEMARK"; break;
364 case FF_END: name = "END"; break;
365 case FF_0DECIMAL: name = "0DECIMAL"; break;
368 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
370 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
398 if (ckWARN(WARN_SYNTAX))
399 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
404 item = s = SvPV(sv, len);
407 itemsize = sv_len_utf8(sv);
408 if (itemsize != len) {
410 if (itemsize > fieldsize) {
411 itemsize = fieldsize;
412 itembytes = itemsize;
413 sv_pos_u2b(sv, &itembytes, 0);
417 send = chophere = s + itembytes;
427 sv_pos_b2u(sv, &itemsize);
432 if (itemsize > fieldsize)
433 itemsize = fieldsize;
434 send = chophere = s + itemsize;
446 item = s = SvPV(sv, len);
449 itemsize = sv_len_utf8(sv);
450 if (itemsize != len) {
452 if (itemsize <= fieldsize) {
453 send = chophere = s + itemsize;
464 itemsize = fieldsize;
465 itembytes = itemsize;
466 sv_pos_u2b(sv, &itembytes, 0);
467 send = chophere = s + itembytes;
468 while (s < send || (s == send && isSPACE(*s))) {
478 if (strchr(PL_chopset, *s))
483 itemsize = chophere - item;
484 sv_pos_b2u(sv, &itemsize);
491 if (itemsize <= fieldsize) {
492 send = chophere = s + itemsize;
503 itemsize = fieldsize;
504 send = chophere = s + itemsize;
505 while (s < send || (s == send && isSPACE(*s))) {
515 if (strchr(PL_chopset, *s))
520 itemsize = chophere - item;
525 arg = fieldsize - itemsize;
534 arg = fieldsize - itemsize;
548 if (UTF8_IS_CONTINUED(*s)) {
549 switch (UTF8SKIP(s)) {
560 if ( !((*t++ = *s++) & ~31) )
568 int ch = *t++ = *s++;
571 if ( !((*t++ = *s++) & ~31) )
580 while (*s && isSPACE(*s))
587 item = s = SvPV(sv, len);
589 item_is_utf = FALSE; /* XXX is this correct? */
601 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
602 sv_catpvn(PL_formtarget, item, itemsize);
603 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
604 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
609 /* If the field is marked with ^ and the value is undefined,
612 if ((arg & 512) && !SvOK(sv)) {
620 /* Formats aren't yet marked for locales, so assume "yes". */
622 STORE_NUMERIC_STANDARD_SET_LOCAL();
623 #if defined(USE_LONG_DOUBLE)
625 sprintf(t, "%#*.*" PERL_PRIfldbl,
626 (int) fieldsize, (int) arg & 255, value);
628 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
633 (int) fieldsize, (int) arg & 255, value);
636 (int) fieldsize, value);
639 RESTORE_NUMERIC_STANDARD();
645 /* If the field is marked with ^ and the value is undefined,
648 if ((arg & 512) && !SvOK(sv)) {
656 /* Formats aren't yet marked for locales, so assume "yes". */
658 STORE_NUMERIC_STANDARD_SET_LOCAL();
659 #if defined(USE_LONG_DOUBLE)
661 sprintf(t, "%#0*.*" PERL_PRIfldbl,
662 (int) fieldsize, (int) arg & 255, value);
663 /* is this legal? I don't have long doubles */
665 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
669 sprintf(t, "%#0*.*f",
670 (int) fieldsize, (int) arg & 255, value);
673 (int) fieldsize, value);
676 RESTORE_NUMERIC_STANDARD();
683 while (t-- > linemark && *t == ' ') ;
691 if (arg) { /* repeat until fields exhausted? */
693 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
694 lines += FmLINES(PL_formtarget);
697 if (strnEQ(linemark, linemark - arg, arg))
698 DIE(aTHX_ "Runaway format");
700 FmLINES(PL_formtarget) = lines;
702 RETURNOP(cLISTOP->op_first);
715 while (*s && isSPACE(*s) && s < send)
719 arg = fieldsize - itemsize;
726 if (strnEQ(s," ",3)) {
727 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
738 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
739 FmLINES(PL_formtarget) += lines;
751 if (PL_stack_base + *PL_markstack_ptr == SP) {
753 if (GIMME_V == G_SCALAR)
754 XPUSHs(sv_2mortal(newSViv(0)));
755 RETURNOP(PL_op->op_next->op_next);
757 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
758 pp_pushmark(); /* push dst */
759 pp_pushmark(); /* push src */
760 ENTER; /* enter outer scope */
763 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
765 ENTER; /* enter inner scope */
768 src = PL_stack_base[*PL_markstack_ptr];
773 if (PL_op->op_type == OP_MAPSTART)
774 pp_pushmark(); /* push top */
775 return ((LOGOP*)PL_op->op_next)->op_other;
780 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
786 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
792 /* first, move source pointer to the next item in the source list */
793 ++PL_markstack_ptr[-1];
795 /* if there are new items, push them into the destination list */
797 /* might need to make room back there first */
798 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
799 /* XXX this implementation is very pessimal because the stack
800 * is repeatedly extended for every set of items. Is possible
801 * to do this without any stack extension or copying at all
802 * by maintaining a separate list over which the map iterates
803 * (like foreach does). --gsar */
805 /* everything in the stack after the destination list moves
806 * towards the end the stack by the amount of room needed */
807 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
809 /* items to shift up (accounting for the moved source pointer) */
810 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
812 /* This optimization is by Ben Tilly and it does
813 * things differently from what Sarathy (gsar)
814 * is describing. The downside of this optimization is
815 * that leaves "holes" (uninitialized and hopefully unused areas)
816 * to the Perl stack, but on the other hand this
817 * shouldn't be a problem. If Sarathy's idea gets
818 * implemented, this optimization should become
819 * irrelevant. --jhi */
821 shift = count; /* Avoid shifting too often --Ben Tilly */
826 PL_markstack_ptr[-1] += shift;
827 *PL_markstack_ptr += shift;
831 /* copy the new items down to the destination list */
832 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
834 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
836 LEAVE; /* exit inner scope */
839 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
842 (void)POPMARK; /* pop top */
843 LEAVE; /* exit outer scope */
844 (void)POPMARK; /* pop src */
845 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
846 (void)POPMARK; /* pop dst */
847 SP = PL_stack_base + POPMARK; /* pop original mark */
848 if (gimme == G_SCALAR) {
852 else if (gimme == G_ARRAY)
859 ENTER; /* enter inner scope */
862 /* set $_ to the new source item */
863 src = PL_stack_base[PL_markstack_ptr[-1]];
867 RETURNOP(cLOGOP->op_other);
873 djSP; dMARK; dORIGMARK;
875 SV **myorigmark = ORIGMARK;
881 OP* nextop = PL_op->op_next;
883 bool hasargs = FALSE;
886 if (gimme != G_ARRAY) {
892 SAVEVPTR(PL_sortcop);
893 if (PL_op->op_flags & OPf_STACKED) {
894 if (PL_op->op_flags & OPf_SPECIAL) {
895 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
896 kid = kUNOP->op_first; /* pass rv2gv */
897 kid = kUNOP->op_first; /* pass leave */
898 PL_sortcop = kid->op_next;
899 stash = CopSTASH(PL_curcop);
902 cv = sv_2cv(*++MARK, &stash, &gv, 0);
903 if (cv && SvPOK(cv)) {
905 char *proto = SvPV((SV*)cv, n_a);
906 if (proto && strEQ(proto, "$$")) {
910 if (!(cv && CvROOT(cv))) {
911 if (cv && CvXSUB(cv)) {
915 SV *tmpstr = sv_newmortal();
916 gv_efullname3(tmpstr, gv, Nullch);
917 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
921 DIE(aTHX_ "Undefined subroutine in sort");
926 PL_sortcop = (OP*)cv;
928 PL_sortcop = CvSTART(cv);
929 SAVEVPTR(CvROOT(cv)->op_ppaddr);
930 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
933 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
939 stash = CopSTASH(PL_curcop);
943 while (MARK < SP) { /* This may or may not shift down one here. */
945 if ((*up = *++MARK)) { /* Weed out nulls. */
947 if (!PL_sortcop && !SvPOK(*up)) {
952 (void)sv_2pv(*up, &n_a);
957 max = --up - myorigmark;
962 bool oldcatch = CATCH_GET;
968 PUSHSTACKi(PERLSI_SORT);
969 if (!hasargs && !is_xsub) {
970 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
971 SAVESPTR(PL_firstgv);
972 SAVESPTR(PL_secondgv);
973 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
974 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
975 PL_sortstash = stash;
978 sv_lock((SV *)PL_firstgv);
979 sv_lock((SV *)PL_secondgv);
981 SAVESPTR(GvSV(PL_firstgv));
982 SAVESPTR(GvSV(PL_secondgv));
985 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
986 if (!(PL_op->op_flags & OPf_SPECIAL)) {
987 cx->cx_type = CXt_SUB;
988 cx->blk_gimme = G_SCALAR;
991 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
993 PL_sortcxix = cxstack_ix;
995 if (hasargs && !is_xsub) {
996 /* This is mostly copied from pp_entersub */
997 AV *av = (AV*)PL_curpad[0];
1000 cx->blk_sub.savearray = GvAV(PL_defgv);
1001 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1002 #endif /* USE_THREADS */
1003 cx->blk_sub.oldcurpad = PL_curpad;
1004 cx->blk_sub.argarray = av;
1006 qsortsv((myorigmark+1), max,
1007 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1009 POPBLOCK(cx,PL_curpm);
1010 PL_stack_sp = newsp;
1012 CATCH_SET(oldcatch);
1017 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1018 qsortsv(ORIGMARK+1, max,
1019 (PL_op->op_private & OPpSORT_NUMERIC)
1020 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1021 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1022 : ( overloading ? amagic_ncmp : sv_ncmp))
1023 : ( (PL_op->op_private & OPpLOCALE)
1026 : sv_cmp_locale_static)
1027 : ( overloading ? amagic_cmp : sv_cmp_static)));
1028 if (PL_op->op_private & OPpSORT_REVERSE) {
1029 SV **p = ORIGMARK+1;
1030 SV **q = ORIGMARK+max;
1040 PL_stack_sp = ORIGMARK + max;
1048 if (GIMME == G_ARRAY)
1050 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1051 return cLOGOP->op_other;
1060 if (GIMME == G_ARRAY) {
1061 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1065 SV *targ = PAD_SV(PL_op->op_targ);
1068 if (PL_op->op_private & OPpFLIP_LINENUM) {
1070 flip = PL_last_in_gv
1071 && (gp_io = GvIOp(PL_last_in_gv))
1072 && SvIV(sv) == (IV)IoLINES(gp_io);
1077 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1078 if (PL_op->op_flags & OPf_SPECIAL) {
1086 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1099 if (GIMME == G_ARRAY) {
1105 if (SvGMAGICAL(left))
1107 if (SvGMAGICAL(right))
1110 if (SvNIOKp(left) || !SvPOKp(left) ||
1111 SvNIOKp(right) || !SvPOKp(right) ||
1112 (looks_like_number(left) && *SvPVX(left) != '0' &&
1113 looks_like_number(right) && *SvPVX(right) != '0'))
1115 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1116 DIE(aTHX_ "Range iterator outside integer range");
1127 sv = sv_2mortal(newSViv(i++));
1132 SV *final = sv_mortalcopy(right);
1134 char *tmps = SvPV(final, len);
1136 sv = sv_mortalcopy(left);
1138 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1140 if (strEQ(SvPVX(sv),tmps))
1142 sv = sv_2mortal(newSVsv(sv));
1149 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1151 if ((PL_op->op_private & OPpFLIP_LINENUM)
1152 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1154 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1155 sv_catpv(targ, "E0");
1166 S_dopoptolabel(pTHX_ char *label)
1169 register PERL_CONTEXT *cx;
1171 for (i = cxstack_ix; i >= 0; i--) {
1173 switch (CxTYPE(cx)) {
1175 if (ckWARN(WARN_EXITING))
1176 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1177 PL_op_name[PL_op->op_type]);
1180 if (ckWARN(WARN_EXITING))
1181 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1182 PL_op_name[PL_op->op_type]);
1185 if (ckWARN(WARN_EXITING))
1186 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1187 PL_op_name[PL_op->op_type]);
1190 if (ckWARN(WARN_EXITING))
1191 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1192 PL_op_name[PL_op->op_type]);
1195 if (ckWARN(WARN_EXITING))
1196 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1197 PL_op_name[PL_op->op_type]);
1200 if (!cx->blk_loop.label ||
1201 strNE(label, cx->blk_loop.label) ) {
1202 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1203 (long)i, cx->blk_loop.label));
1206 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1214 Perl_dowantarray(pTHX)
1216 I32 gimme = block_gimme();
1217 return (gimme == G_VOID) ? G_SCALAR : gimme;
1221 Perl_block_gimme(pTHX)
1225 cxix = dopoptosub(cxstack_ix);
1229 switch (cxstack[cxix].blk_gimme) {
1237 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1244 S_dopoptosub(pTHX_ I32 startingblock)
1246 return dopoptosub_at(cxstack, startingblock);
1250 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1253 register PERL_CONTEXT *cx;
1254 for (i = startingblock; i >= 0; i--) {
1256 switch (CxTYPE(cx)) {
1262 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1270 S_dopoptoeval(pTHX_ I32 startingblock)
1273 register PERL_CONTEXT *cx;
1274 for (i = startingblock; i >= 0; i--) {
1276 switch (CxTYPE(cx)) {
1280 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1288 S_dopoptoloop(pTHX_ I32 startingblock)
1291 register PERL_CONTEXT *cx;
1292 for (i = startingblock; i >= 0; i--) {
1294 switch (CxTYPE(cx)) {
1296 if (ckWARN(WARN_EXITING))
1297 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1298 PL_op_name[PL_op->op_type]);
1301 if (ckWARN(WARN_EXITING))
1302 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1303 PL_op_name[PL_op->op_type]);
1306 if (ckWARN(WARN_EXITING))
1307 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1308 PL_op_name[PL_op->op_type]);
1311 if (ckWARN(WARN_EXITING))
1312 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1313 PL_op_name[PL_op->op_type]);
1316 if (ckWARN(WARN_EXITING))
1317 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1318 PL_op_name[PL_op->op_type]);
1321 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1329 Perl_dounwind(pTHX_ I32 cxix)
1331 register PERL_CONTEXT *cx;
1334 while (cxstack_ix > cxix) {
1336 cx = &cxstack[cxstack_ix];
1337 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1338 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1339 /* Note: we don't need to restore the base context info till the end. */
1340 switch (CxTYPE(cx)) {
1343 continue; /* not break */
1365 * Closures mentioned at top level of eval cannot be referenced
1366 * again, and their presence indirectly causes a memory leak.
1367 * (Note that the fact that compcv and friends are still set here
1368 * is, AFAIK, an accident.) --Chip
1370 * XXX need to get comppad et al from eval's cv rather than
1371 * relying on the incidental global values.
1374 S_free_closures(pTHX)
1376 SV **svp = AvARRAY(PL_comppad_name);
1378 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1380 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1382 svp[ix] = &PL_sv_undef;
1386 SvREFCNT_dec(CvOUTSIDE(sv));
1387 CvOUTSIDE(sv) = Nullcv;
1400 Perl_qerror(pTHX_ SV *err)
1403 sv_catsv(ERRSV, err);
1405 sv_catsv(PL_errors, err);
1407 Perl_warn(aTHX_ "%"SVf, err);
1412 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1417 register PERL_CONTEXT *cx;
1422 if (PL_in_eval & EVAL_KEEPERR) {
1423 static char prefix[] = "\t(in cleanup) ";
1428 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1431 if (*e != *message || strNE(e,message))
1435 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1436 sv_catpvn(err, prefix, sizeof(prefix)-1);
1437 sv_catpvn(err, message, msglen);
1438 if (ckWARN(WARN_MISC)) {
1439 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1440 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1445 sv_setpvn(ERRSV, message, msglen);
1446 if (PL_hints & HINT_UTF8)
1453 message = SvPVx(ERRSV, msglen);
1455 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1456 && PL_curstackinfo->si_prev)
1465 if (cxix < cxstack_ix)
1468 POPBLOCK(cx,PL_curpm);
1469 if (CxTYPE(cx) != CXt_EVAL) {
1470 PerlIO_write(Perl_error_log, "panic: die ", 11);
1471 PerlIO_write(Perl_error_log, message, msglen);
1476 if (gimme == G_SCALAR)
1477 *++newsp = &PL_sv_undef;
1478 PL_stack_sp = newsp;
1482 /* LEAVE could clobber PL_curcop (see save_re_context())
1483 * XXX it might be better to find a way to avoid messing with
1484 * PL_curcop in save_re_context() instead, but this is a more
1485 * minimal fix --GSAR */
1486 PL_curcop = cx->blk_oldcop;
1488 if (optype == OP_REQUIRE) {
1489 char* msg = SvPVx(ERRSV, n_a);
1490 DIE(aTHX_ "%sCompilation failed in require",
1491 *msg ? msg : "Unknown error\n");
1493 return pop_return();
1497 message = SvPVx(ERRSV, msglen);
1500 /* SFIO can really mess with your errno */
1503 PerlIO *serr = Perl_error_log;
1505 PerlIO_write(serr, message, msglen);
1506 (void)PerlIO_flush(serr);
1519 if (SvTRUE(left) != SvTRUE(right))
1531 RETURNOP(cLOGOP->op_other);
1540 RETURNOP(cLOGOP->op_other);
1546 register I32 cxix = dopoptosub(cxstack_ix);
1547 register PERL_CONTEXT *cx;
1548 register PERL_CONTEXT *ccstack = cxstack;
1549 PERL_SI *top_si = PL_curstackinfo;
1560 /* we may be in a higher stacklevel, so dig down deeper */
1561 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1562 top_si = top_si->si_prev;
1563 ccstack = top_si->si_cxstack;
1564 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1567 if (GIMME != G_ARRAY)
1571 if (PL_DBsub && cxix >= 0 &&
1572 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1576 cxix = dopoptosub_at(ccstack, cxix - 1);
1579 cx = &ccstack[cxix];
1580 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1581 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1582 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1583 field below is defined for any cx. */
1584 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1585 cx = &ccstack[dbcxix];
1588 stashname = CopSTASHPV(cx->blk_oldcop);
1589 if (GIMME != G_ARRAY) {
1591 PUSHs(&PL_sv_undef);
1594 sv_setpv(TARG, stashname);
1601 PUSHs(&PL_sv_undef);
1603 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1604 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1605 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1608 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1609 /* So is ccstack[dbcxix]. */
1611 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1612 PUSHs(sv_2mortal(sv));
1613 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1616 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1617 PUSHs(sv_2mortal(newSViv(0)));
1619 gimme = (I32)cx->blk_gimme;
1620 if (gimme == G_VOID)
1621 PUSHs(&PL_sv_undef);
1623 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1624 if (CxTYPE(cx) == CXt_EVAL) {
1626 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1627 PUSHs(cx->blk_eval.cur_text);
1631 else if (cx->blk_eval.old_namesv) {
1632 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1635 /* eval BLOCK (try blocks have old_namesv == 0) */
1637 PUSHs(&PL_sv_undef);
1638 PUSHs(&PL_sv_undef);
1642 PUSHs(&PL_sv_undef);
1643 PUSHs(&PL_sv_undef);
1645 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1646 && CopSTASH_eq(PL_curcop, PL_debstash))
1648 AV *ary = cx->blk_sub.argarray;
1649 int off = AvARRAY(ary) - AvALLOC(ary);
1653 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1656 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1659 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1660 av_extend(PL_dbargs, AvFILLp(ary) + off);
1661 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1662 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1664 /* XXX only hints propagated via op_private are currently
1665 * visible (others are not easily accessible, since they
1666 * use the global PL_hints) */
1667 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1668 HINT_PRIVATE_MASK)));
1671 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1673 if (old_warnings == pWARN_NONE ||
1674 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1675 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1676 else if (old_warnings == pWARN_ALL ||
1677 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1678 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1680 mask = newSVsv(old_warnings);
1681 PUSHs(sv_2mortal(mask));
1696 sv_reset(tmps, CopSTASH(PL_curcop));
1708 PL_curcop = (COP*)PL_op;
1709 TAINT_NOT; /* Each statement is presumed innocent */
1710 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1713 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1717 register PERL_CONTEXT *cx;
1718 I32 gimme = G_ARRAY;
1725 DIE(aTHX_ "No DB::DB routine defined");
1727 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1739 push_return(PL_op->op_next);
1740 PUSHBLOCK(cx, CXt_SUB, SP);
1743 (void)SvREFCNT_inc(cv);
1744 SAVEVPTR(PL_curpad);
1745 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1746 RETURNOP(CvSTART(cv));
1760 register PERL_CONTEXT *cx;
1761 I32 gimme = GIMME_V;
1763 U32 cxtype = CXt_LOOP;
1772 if (PL_op->op_flags & OPf_SPECIAL) {
1773 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1774 SAVEGENERICSV(*svp);
1778 #endif /* USE_THREADS */
1779 if (PL_op->op_targ) {
1780 #ifndef USE_ITHREADS
1781 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1784 SAVEPADSV(PL_op->op_targ);
1785 iterdata = (void*)PL_op->op_targ;
1786 cxtype |= CXp_PADVAR;
1791 svp = &GvSV(gv); /* symbol table variable */
1792 SAVEGENERICSV(*svp);
1795 iterdata = (void*)gv;
1801 PUSHBLOCK(cx, cxtype, SP);
1803 PUSHLOOP(cx, iterdata, MARK);
1805 PUSHLOOP(cx, svp, MARK);
1807 if (PL_op->op_flags & OPf_STACKED) {
1808 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1809 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1811 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1812 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1813 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1814 looks_like_number((SV*)cx->blk_loop.iterary) &&
1815 *SvPVX(cx->blk_loop.iterary) != '0'))
1817 if (SvNV(sv) < IV_MIN ||
1818 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1819 DIE(aTHX_ "Range iterator outside integer range");
1820 cx->blk_loop.iterix = SvIV(sv);
1821 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1824 cx->blk_loop.iterlval = newSVsv(sv);
1828 cx->blk_loop.iterary = PL_curstack;
1829 AvFILLp(PL_curstack) = SP - PL_stack_base;
1830 cx->blk_loop.iterix = MARK - PL_stack_base;
1839 register PERL_CONTEXT *cx;
1840 I32 gimme = GIMME_V;
1846 PUSHBLOCK(cx, CXt_LOOP, SP);
1847 PUSHLOOP(cx, 0, SP);
1855 register PERL_CONTEXT *cx;
1863 newsp = PL_stack_base + cx->blk_loop.resetsp;
1866 if (gimme == G_VOID)
1868 else if (gimme == G_SCALAR) {
1870 *++newsp = sv_mortalcopy(*SP);
1872 *++newsp = &PL_sv_undef;
1876 *++newsp = sv_mortalcopy(*++mark);
1877 TAINT_NOT; /* Each item is independent */
1883 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1884 PL_curpm = newpm; /* ... and pop $1 et al */
1896 register PERL_CONTEXT *cx;
1897 bool popsub2 = FALSE;
1898 bool clear_errsv = FALSE;
1905 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1906 if (cxstack_ix == PL_sortcxix
1907 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1909 if (cxstack_ix > PL_sortcxix)
1910 dounwind(PL_sortcxix);
1911 AvARRAY(PL_curstack)[1] = *SP;
1912 PL_stack_sp = PL_stack_base + 1;
1917 cxix = dopoptosub(cxstack_ix);
1919 DIE(aTHX_ "Can't return outside a subroutine");
1920 if (cxix < cxstack_ix)
1924 switch (CxTYPE(cx)) {
1929 if (!(PL_in_eval & EVAL_KEEPERR))
1934 if (AvFILLp(PL_comppad_name) >= 0)
1937 if (optype == OP_REQUIRE &&
1938 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1940 /* Unassume the success we assumed earlier. */
1941 SV *nsv = cx->blk_eval.old_namesv;
1942 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1943 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1950 DIE(aTHX_ "panic: return");
1954 if (gimme == G_SCALAR) {
1957 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1959 *++newsp = SvREFCNT_inc(*SP);
1964 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1966 *++newsp = sv_mortalcopy(sv);
1971 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1974 *++newsp = sv_mortalcopy(*SP);
1977 *++newsp = &PL_sv_undef;
1979 else if (gimme == G_ARRAY) {
1980 while (++MARK <= SP) {
1981 *++newsp = (popsub2 && SvTEMP(*MARK))
1982 ? *MARK : sv_mortalcopy(*MARK);
1983 TAINT_NOT; /* Each item is independent */
1986 PL_stack_sp = newsp;
1988 /* Stack values are safe: */
1990 POPSUB(cx,sv); /* release CV and @_ ... */
1994 PL_curpm = newpm; /* ... and pop $1 et al */
2000 return pop_return();
2007 register PERL_CONTEXT *cx;
2017 if (PL_op->op_flags & OPf_SPECIAL) {
2018 cxix = dopoptoloop(cxstack_ix);
2020 DIE(aTHX_ "Can't \"last\" outside a loop block");
2023 cxix = dopoptolabel(cPVOP->op_pv);
2025 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2027 if (cxix < cxstack_ix)
2032 switch (CxTYPE(cx)) {
2035 newsp = PL_stack_base + cx->blk_loop.resetsp;
2036 nextop = cx->blk_loop.last_op->op_next;
2040 nextop = pop_return();
2044 nextop = pop_return();
2048 nextop = pop_return();
2051 DIE(aTHX_ "panic: last");
2055 if (gimme == G_SCALAR) {
2057 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2058 ? *SP : sv_mortalcopy(*SP);
2060 *++newsp = &PL_sv_undef;
2062 else if (gimme == G_ARRAY) {
2063 while (++MARK <= SP) {
2064 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2065 ? *MARK : sv_mortalcopy(*MARK);
2066 TAINT_NOT; /* Each item is independent */
2072 /* Stack values are safe: */
2075 POPLOOP(cx); /* release loop vars ... */
2079 POPSUB(cx,sv); /* release CV and @_ ... */
2082 PL_curpm = newpm; /* ... and pop $1 et al */
2092 register PERL_CONTEXT *cx;
2095 if (PL_op->op_flags & OPf_SPECIAL) {
2096 cxix = dopoptoloop(cxstack_ix);
2098 DIE(aTHX_ "Can't \"next\" outside a loop block");
2101 cxix = dopoptolabel(cPVOP->op_pv);
2103 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2105 if (cxix < cxstack_ix)
2108 /* clear off anything above the scope we're re-entering, but
2109 * save the rest until after a possible continue block */
2110 inner = PL_scopestack_ix;
2112 if (PL_scopestack_ix < inner)
2113 leave_scope(PL_scopestack[PL_scopestack_ix]);
2114 return cx->blk_loop.next_op;
2120 register PERL_CONTEXT *cx;
2123 if (PL_op->op_flags & OPf_SPECIAL) {
2124 cxix = dopoptoloop(cxstack_ix);
2126 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2129 cxix = dopoptolabel(cPVOP->op_pv);
2131 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2133 if (cxix < cxstack_ix)
2137 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2138 LEAVE_SCOPE(oldsave);
2139 return cx->blk_loop.redo_op;
2143 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2147 static char too_deep[] = "Target of goto is too deeply nested";
2150 Perl_croak(aTHX_ too_deep);
2151 if (o->op_type == OP_LEAVE ||
2152 o->op_type == OP_SCOPE ||
2153 o->op_type == OP_LEAVELOOP ||
2154 o->op_type == OP_LEAVETRY)
2156 *ops++ = cUNOPo->op_first;
2158 Perl_croak(aTHX_ too_deep);
2161 if (o->op_flags & OPf_KIDS) {
2162 /* First try all the kids at this level, since that's likeliest. */
2163 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2164 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2165 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2168 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2169 if (kid == PL_lastgotoprobe)
2171 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2173 (ops[-1]->op_type != OP_NEXTSTATE &&
2174 ops[-1]->op_type != OP_DBSTATE)))
2176 if ((o = dofindlabel(kid, label, ops, oplimit)))
2195 register PERL_CONTEXT *cx;
2196 #define GOTO_DEPTH 64
2197 OP *enterops[GOTO_DEPTH];
2199 int do_dump = (PL_op->op_type == OP_DUMP);
2200 static char must_have_label[] = "goto must have label";
2203 if (PL_op->op_flags & OPf_STACKED) {
2207 /* This egregious kludge implements goto &subroutine */
2208 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2210 register PERL_CONTEXT *cx;
2211 CV* cv = (CV*)SvRV(sv);
2217 if (!CvROOT(cv) && !CvXSUB(cv)) {
2222 /* autoloaded stub? */
2223 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2225 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2226 GvNAMELEN(gv), FALSE);
2227 if (autogv && (cv = GvCV(autogv)))
2229 tmpstr = sv_newmortal();
2230 gv_efullname3(tmpstr, gv, Nullch);
2231 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2233 DIE(aTHX_ "Goto undefined subroutine");
2236 /* First do some returnish stuff. */
2237 cxix = dopoptosub(cxstack_ix);
2239 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2240 if (cxix < cxstack_ix)
2243 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2244 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2246 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2247 /* put @_ back onto stack */
2248 AV* av = cx->blk_sub.argarray;
2250 items = AvFILLp(av) + 1;
2252 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2253 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2254 PL_stack_sp += items;
2256 SvREFCNT_dec(GvAV(PL_defgv));
2257 GvAV(PL_defgv) = cx->blk_sub.savearray;
2258 #endif /* USE_THREADS */
2259 /* abandon @_ if it got reified */
2261 (void)sv_2mortal((SV*)av); /* delay until return */
2263 av_extend(av, items-1);
2264 AvFLAGS(av) = AVf_REIFY;
2265 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2268 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2271 av = (AV*)PL_curpad[0];
2273 av = GvAV(PL_defgv);
2275 items = AvFILLp(av) + 1;
2277 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2278 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2279 PL_stack_sp += items;
2281 if (CxTYPE(cx) == CXt_SUB &&
2282 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2283 SvREFCNT_dec(cx->blk_sub.cv);
2284 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2285 LEAVE_SCOPE(oldsave);
2287 /* Now do some callish stuff. */
2290 #ifdef PERL_XSUB_OLDSTYLE
2291 if (CvOLDSTYLE(cv)) {
2292 I32 (*fp3)(int,int,int);
2297 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2298 items = (*fp3)(CvXSUBANY(cv).any_i32,
2299 mark - PL_stack_base + 1,
2301 SP = PL_stack_base + items;
2304 #endif /* PERL_XSUB_OLDSTYLE */
2309 PL_stack_sp--; /* There is no cv arg. */
2310 /* Push a mark for the start of arglist */
2312 (void)(*CvXSUB(cv))(aTHXo_ cv);
2313 /* Pop the current context like a decent sub should */
2314 POPBLOCK(cx, PL_curpm);
2315 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2318 return pop_return();
2321 AV* padlist = CvPADLIST(cv);
2322 SV** svp = AvARRAY(padlist);
2323 if (CxTYPE(cx) == CXt_EVAL) {
2324 PL_in_eval = cx->blk_eval.old_in_eval;
2325 PL_eval_root = cx->blk_eval.old_eval_root;
2326 cx->cx_type = CXt_SUB;
2327 cx->blk_sub.hasargs = 0;
2329 cx->blk_sub.cv = cv;
2330 cx->blk_sub.olddepth = CvDEPTH(cv);
2332 if (CvDEPTH(cv) < 2)
2333 (void)SvREFCNT_inc(cv);
2334 else { /* save temporaries on recursion? */
2335 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2336 sub_crush_depth(cv);
2337 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2338 AV *newpad = newAV();
2339 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2340 I32 ix = AvFILLp((AV*)svp[1]);
2341 I32 names_fill = AvFILLp((AV*)svp[0]);
2342 svp = AvARRAY(svp[0]);
2343 for ( ;ix > 0; ix--) {
2344 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2345 char *name = SvPVX(svp[ix]);
2346 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2349 /* outer lexical or anon code */
2350 av_store(newpad, ix,
2351 SvREFCNT_inc(oldpad[ix]) );
2353 else { /* our own lexical */
2355 av_store(newpad, ix, sv = (SV*)newAV());
2356 else if (*name == '%')
2357 av_store(newpad, ix, sv = (SV*)newHV());
2359 av_store(newpad, ix, sv = NEWSV(0,0));
2363 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2364 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2367 av_store(newpad, ix, sv = NEWSV(0,0));
2371 if (cx->blk_sub.hasargs) {
2374 av_store(newpad, 0, (SV*)av);
2375 AvFLAGS(av) = AVf_REIFY;
2377 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2378 AvFILLp(padlist) = CvDEPTH(cv);
2379 svp = AvARRAY(padlist);
2383 if (!cx->blk_sub.hasargs) {
2384 AV* av = (AV*)PL_curpad[0];
2386 items = AvFILLp(av) + 1;
2388 /* Mark is at the end of the stack. */
2390 Copy(AvARRAY(av), SP + 1, items, SV*);
2395 #endif /* USE_THREADS */
2396 SAVEVPTR(PL_curpad);
2397 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2399 if (cx->blk_sub.hasargs)
2400 #endif /* USE_THREADS */
2402 AV* av = (AV*)PL_curpad[0];
2406 cx->blk_sub.savearray = GvAV(PL_defgv);
2407 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2408 #endif /* USE_THREADS */
2409 cx->blk_sub.oldcurpad = PL_curpad;
2410 cx->blk_sub.argarray = av;
2413 if (items >= AvMAX(av) + 1) {
2415 if (AvARRAY(av) != ary) {
2416 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2417 SvPVX(av) = (char*)ary;
2419 if (items >= AvMAX(av) + 1) {
2420 AvMAX(av) = items - 1;
2421 Renew(ary,items+1,SV*);
2423 SvPVX(av) = (char*)ary;
2426 Copy(mark,AvARRAY(av),items,SV*);
2427 AvFILLp(av) = items - 1;
2428 assert(!AvREAL(av));
2435 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2437 * We do not care about using sv to call CV;
2438 * it's for informational purposes only.
2440 SV *sv = GvSV(PL_DBsub);
2443 if (PERLDB_SUB_NN) {
2444 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2447 gv_efullname3(sv, CvGV(cv), Nullch);
2450 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2451 PUSHMARK( PL_stack_sp );
2452 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2456 RETURNOP(CvSTART(cv));
2460 label = SvPV(sv,n_a);
2461 if (!(do_dump || *label))
2462 DIE(aTHX_ must_have_label);
2465 else if (PL_op->op_flags & OPf_SPECIAL) {
2467 DIE(aTHX_ must_have_label);
2470 label = cPVOP->op_pv;
2472 if (label && *label) {
2477 PL_lastgotoprobe = 0;
2479 for (ix = cxstack_ix; ix >= 0; ix--) {
2481 switch (CxTYPE(cx)) {
2483 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2486 gotoprobe = cx->blk_oldcop->op_sibling;
2492 gotoprobe = cx->blk_oldcop->op_sibling;
2494 gotoprobe = PL_main_root;
2497 if (CvDEPTH(cx->blk_sub.cv)) {
2498 gotoprobe = CvROOT(cx->blk_sub.cv);
2504 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2507 DIE(aTHX_ "panic: goto");
2508 gotoprobe = PL_main_root;
2512 retop = dofindlabel(gotoprobe, label,
2513 enterops, enterops + GOTO_DEPTH);
2517 PL_lastgotoprobe = gotoprobe;
2520 DIE(aTHX_ "Can't find label %s", label);
2522 /* pop unwanted frames */
2524 if (ix < cxstack_ix) {
2531 oldsave = PL_scopestack[PL_scopestack_ix];
2532 LEAVE_SCOPE(oldsave);
2535 /* push wanted frames */
2537 if (*enterops && enterops[1]) {
2539 for (ix = 1; enterops[ix]; ix++) {
2540 PL_op = enterops[ix];
2541 /* Eventually we may want to stack the needed arguments
2542 * for each op. For now, we punt on the hard ones. */
2543 if (PL_op->op_type == OP_ENTERITER)
2544 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2545 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2553 if (!retop) retop = PL_main_start;
2555 PL_restartop = retop;
2556 PL_do_undump = TRUE;
2560 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2561 PL_do_undump = FALSE;
2577 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2581 PL_exit_flags |= PERL_EXIT_EXPECTED;
2583 PUSHs(&PL_sv_undef);
2591 NV value = SvNVx(GvSV(cCOP->cop_gv));
2592 register I32 match = I_32(value);
2595 if (((NV)match) > value)
2596 --match; /* was fractional--truncate other way */
2598 match -= cCOP->uop.scop.scop_offset;
2601 else if (match > cCOP->uop.scop.scop_max)
2602 match = cCOP->uop.scop.scop_max;
2603 PL_op = cCOP->uop.scop.scop_next[match];
2613 PL_op = PL_op->op_next; /* can't assume anything */
2616 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2617 match -= cCOP->uop.scop.scop_offset;
2620 else if (match > cCOP->uop.scop.scop_max)
2621 match = cCOP->uop.scop.scop_max;
2622 PL_op = cCOP->uop.scop.scop_next[match];
2631 S_save_lines(pTHX_ AV *array, SV *sv)
2633 register char *s = SvPVX(sv);
2634 register char *send = SvPVX(sv) + SvCUR(sv);
2636 register I32 line = 1;
2638 while (s && s < send) {
2639 SV *tmpstr = NEWSV(85,0);
2641 sv_upgrade(tmpstr, SVt_PVMG);
2642 t = strchr(s, '\n');
2648 sv_setpvn(tmpstr, s, t - s);
2649 av_store(array, line++, tmpstr);
2654 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2656 S_docatch_body(pTHX_ va_list args)
2658 return docatch_body();
2663 S_docatch_body(pTHX)
2670 S_docatch(pTHX_ OP *o)
2674 volatile PERL_SI *cursi = PL_curstackinfo;
2678 assert(CATCH_GET == TRUE);
2681 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2683 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2689 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2695 if (PL_restartop && cursi == PL_curstackinfo) {
2696 PL_op = PL_restartop;
2713 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2714 /* sv Text to convert to OP tree. */
2715 /* startop op_free() this to undo. */
2716 /* code Short string id of the caller. */
2718 dSP; /* Make POPBLOCK work. */
2721 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2725 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2726 char *tmpbuf = tbuf;
2732 /* switch to eval mode */
2734 if (PL_curcop == &PL_compiling) {
2735 SAVECOPSTASH_FREE(&PL_compiling);
2736 CopSTASH_set(&PL_compiling, PL_curstash);
2738 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2739 SV *sv = sv_newmortal();
2740 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2741 code, (unsigned long)++PL_evalseq,
2742 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2746 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2747 SAVECOPFILE_FREE(&PL_compiling);
2748 CopFILE_set(&PL_compiling, tmpbuf+2);
2749 SAVECOPLINE(&PL_compiling);
2750 CopLINE_set(&PL_compiling, 1);
2751 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2752 deleting the eval's FILEGV from the stash before gv_check() runs
2753 (i.e. before run-time proper). To work around the coredump that
2754 ensues, we always turn GvMULTI_on for any globals that were
2755 introduced within evals. See force_ident(). GSAR 96-10-12 */
2756 safestr = savepv(tmpbuf);
2757 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2759 #ifdef OP_IN_REGISTER
2764 PL_hints &= HINT_UTF8;
2767 PL_op->op_type = OP_ENTEREVAL;
2768 PL_op->op_flags = 0; /* Avoid uninit warning. */
2769 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2770 PUSHEVAL(cx, 0, Nullgv);
2771 rop = doeval(G_SCALAR, startop);
2772 POPBLOCK(cx,PL_curpm);
2775 (*startop)->op_type = OP_NULL;
2776 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2778 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2780 if (PL_curcop == &PL_compiling)
2781 PL_compiling.op_private = PL_hints;
2782 #ifdef OP_IN_REGISTER
2788 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2790 S_doeval(pTHX_ int gimme, OP** startop)
2798 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2799 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2804 /* set up a scratch pad */
2807 SAVEVPTR(PL_curpad);
2808 SAVESPTR(PL_comppad);
2809 SAVESPTR(PL_comppad_name);
2810 SAVEI32(PL_comppad_name_fill);
2811 SAVEI32(PL_min_intro_pending);
2812 SAVEI32(PL_max_intro_pending);
2815 for (i = cxstack_ix - 1; i >= 0; i--) {
2816 PERL_CONTEXT *cx = &cxstack[i];
2817 if (CxTYPE(cx) == CXt_EVAL)
2819 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2820 caller = cx->blk_sub.cv;
2825 SAVESPTR(PL_compcv);
2826 PL_compcv = (CV*)NEWSV(1104,0);
2827 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2828 CvEVAL_on(PL_compcv);
2830 CvOWNER(PL_compcv) = 0;
2831 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2832 MUTEX_INIT(CvMUTEXP(PL_compcv));
2833 #endif /* USE_THREADS */
2835 PL_comppad = newAV();
2836 av_push(PL_comppad, Nullsv);
2837 PL_curpad = AvARRAY(PL_comppad);
2838 PL_comppad_name = newAV();
2839 PL_comppad_name_fill = 0;
2840 PL_min_intro_pending = 0;
2843 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2844 PL_curpad[0] = (SV*)newAV();
2845 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2846 #endif /* USE_THREADS */
2848 comppadlist = newAV();
2849 AvREAL_off(comppadlist);
2850 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2851 av_store(comppadlist, 1, (SV*)PL_comppad);
2852 CvPADLIST(PL_compcv) = comppadlist;
2855 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2857 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2860 SAVEFREESV(PL_compcv);
2862 /* make sure we compile in the right package */
2864 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2865 SAVESPTR(PL_curstash);
2866 PL_curstash = CopSTASH(PL_curcop);
2868 SAVESPTR(PL_beginav);
2869 PL_beginav = newAV();
2870 SAVEFREESV(PL_beginav);
2871 SAVEI32(PL_error_count);
2873 /* try to compile it */
2875 PL_eval_root = Nullop;
2877 PL_curcop = &PL_compiling;
2878 PL_curcop->cop_arybase = 0;
2879 SvREFCNT_dec(PL_rs);
2880 PL_rs = newSVpvn("\n", 1);
2881 if (saveop && saveop->op_flags & OPf_SPECIAL)
2882 PL_in_eval |= EVAL_KEEPERR;
2885 if (yyparse() || PL_error_count || !PL_eval_root) {
2889 I32 optype = 0; /* Might be reset by POPEVAL. */
2894 op_free(PL_eval_root);
2895 PL_eval_root = Nullop;
2897 SP = PL_stack_base + POPMARK; /* pop original mark */
2899 POPBLOCK(cx,PL_curpm);
2905 if (optype == OP_REQUIRE) {
2906 char* msg = SvPVx(ERRSV, n_a);
2907 DIE(aTHX_ "%sCompilation failed in require",
2908 *msg ? msg : "Unknown error\n");
2911 char* msg = SvPVx(ERRSV, n_a);
2913 POPBLOCK(cx,PL_curpm);
2915 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2916 (*msg ? msg : "Unknown error\n"));
2918 SvREFCNT_dec(PL_rs);
2919 PL_rs = SvREFCNT_inc(PL_nrs);
2921 MUTEX_LOCK(&PL_eval_mutex);
2923 COND_SIGNAL(&PL_eval_cond);
2924 MUTEX_UNLOCK(&PL_eval_mutex);
2925 #endif /* USE_THREADS */
2928 SvREFCNT_dec(PL_rs);
2929 PL_rs = SvREFCNT_inc(PL_nrs);
2930 CopLINE_set(&PL_compiling, 0);
2932 *startop = PL_eval_root;
2933 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2934 CvOUTSIDE(PL_compcv) = Nullcv;
2936 SAVEFREEOP(PL_eval_root);
2938 scalarvoid(PL_eval_root);
2939 else if (gimme & G_ARRAY)
2942 scalar(PL_eval_root);
2944 DEBUG_x(dump_eval());
2946 /* Register with debugger: */
2947 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2948 CV *cv = get_cv("DB::postponed", FALSE);
2952 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2954 call_sv((SV*)cv, G_DISCARD);
2958 /* compiled okay, so do it */
2960 CvDEPTH(PL_compcv) = 1;
2961 SP = PL_stack_base + POPMARK; /* pop original mark */
2962 PL_op = saveop; /* The caller may need it. */
2963 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2965 MUTEX_LOCK(&PL_eval_mutex);
2967 COND_SIGNAL(&PL_eval_cond);
2968 MUTEX_UNLOCK(&PL_eval_mutex);
2969 #endif /* USE_THREADS */
2971 RETURNOP(PL_eval_start);
2975 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2977 STRLEN namelen = strlen(name);
2980 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2981 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2982 char *pmc = SvPV_nolen(pmcsv);
2985 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2986 fp = PerlIO_open(name, mode);
2989 if (PerlLIO_stat(name, &pmstat) < 0 ||
2990 pmstat.st_mtime < pmcstat.st_mtime)
2992 fp = PerlIO_open(pmc, mode);
2995 fp = PerlIO_open(name, mode);
2998 SvREFCNT_dec(pmcsv);
3001 fp = PerlIO_open(name, mode);
3009 register PERL_CONTEXT *cx;
3014 SV *namesv = Nullsv;
3016 I32 gimme = G_SCALAR;
3017 PerlIO *tryrsfp = 0;
3019 int filter_has_file = 0;
3020 GV *filter_child_proc = 0;
3021 SV *filter_state = 0;
3026 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3027 UV rev = 0, ver = 0, sver = 0;
3029 U8 *s = (U8*)SvPVX(sv);
3030 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3032 rev = utf8_to_uv(s, end - s, &len, 0);
3035 ver = utf8_to_uv(s, end - s, &len, 0);
3038 sver = utf8_to_uv(s, end - s, &len, 0);
3041 if (PERL_REVISION < rev
3042 || (PERL_REVISION == rev
3043 && (PERL_VERSION < ver
3044 || (PERL_VERSION == ver
3045 && PERL_SUBVERSION < sver))))
3047 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3048 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3049 PERL_VERSION, PERL_SUBVERSION);
3053 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3054 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3055 + ((NV)PERL_SUBVERSION/(NV)1000000)
3056 + 0.00000099 < SvNV(sv))
3060 NV nver = (nrev - rev) * 1000;
3061 UV ver = (UV)(nver + 0.0009);
3062 NV nsver = (nver - ver) * 1000;
3063 UV sver = (UV)(nsver + 0.0009);
3065 /* help out with the "use 5.6" confusion */
3066 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3067 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3068 "this is only v%d.%d.%d, stopped"
3069 " (did you mean v%"UVuf".%"UVuf".0?)",
3070 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3071 PERL_SUBVERSION, rev, ver/100);
3074 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3075 "this is only v%d.%d.%d, stopped",
3076 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3083 name = SvPV(sv, len);
3084 if (!(name && len > 0 && *name))
3085 DIE(aTHX_ "Null filename used");
3086 TAINT_PROPER("require");
3087 if (PL_op->op_type == OP_REQUIRE &&
3088 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3089 *svp != &PL_sv_undef)
3092 /* prepare to compile file */
3094 if (PERL_FILE_IS_ABSOLUTE(name)
3095 || (*name == '.' && (name[1] == '/' ||
3096 (name[1] == '.' && name[2] == '/'))))
3099 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3100 #ifdef MACOS_TRADITIONAL
3101 /* We consider paths of the form :a:b ambiguous and interpret them first
3102 as global then as local
3104 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3113 AV *ar = GvAVn(PL_incgv);
3117 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3120 namesv = NEWSV(806, 0);
3121 for (i = 0; i <= AvFILL(ar); i++) {
3122 SV *dirsv = *av_fetch(ar, i, TRUE);
3128 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3129 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3132 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3133 PTR2UV(SvANY(loader)), name);
3134 tryname = SvPVX(namesv);
3145 count = call_sv(loader, G_ARRAY);
3155 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3159 if (SvTYPE(arg) == SVt_PVGV) {
3160 IO *io = GvIO((GV *)arg);
3165 tryrsfp = IoIFP(io);
3166 if (IoTYPE(io) == IoTYPE_PIPE) {
3167 /* reading from a child process doesn't
3168 nest -- when returning from reading
3169 the inner module, the outer one is
3170 unreadable (closed?) I've tried to
3171 save the gv to manage the lifespan of
3172 the pipe, but this didn't help. XXX */
3173 filter_child_proc = (GV *)arg;
3174 (void)SvREFCNT_inc(filter_child_proc);
3177 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3178 PerlIO_close(IoOFP(io));
3190 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3192 (void)SvREFCNT_inc(filter_sub);
3195 filter_state = SP[i];
3196 (void)SvREFCNT_inc(filter_state);
3200 tryrsfp = PerlIO_open("/dev/null",
3214 filter_has_file = 0;
3215 if (filter_child_proc) {
3216 SvREFCNT_dec(filter_child_proc);
3217 filter_child_proc = 0;
3220 SvREFCNT_dec(filter_state);
3224 SvREFCNT_dec(filter_sub);
3229 char *dir = SvPVx(dirsv, n_a);
3230 #ifdef MACOS_TRADITIONAL
3232 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3236 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3238 sv_setpv(namesv, unixdir);
3239 sv_catpv(namesv, unixname);
3241 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3244 TAINT_PROPER("require");
3245 tryname = SvPVX(namesv);
3246 #ifdef MACOS_TRADITIONAL
3248 /* Convert slashes in the name part, but not the directory part, to colons */
3250 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3254 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3256 if (tryname[0] == '.' && tryname[1] == '/')
3264 SAVECOPFILE_FREE(&PL_compiling);
3265 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3266 SvREFCNT_dec(namesv);
3268 if (PL_op->op_type == OP_REQUIRE) {
3269 char *msgstr = name;
3270 if (namesv) { /* did we lookup @INC? */
3271 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3272 SV *dirmsgsv = NEWSV(0, 0);
3273 AV *ar = GvAVn(PL_incgv);
3275 sv_catpvn(msg, " in @INC", 8);
3276 if (instr(SvPVX(msg), ".h "))
3277 sv_catpv(msg, " (change .h to .ph maybe?)");
3278 if (instr(SvPVX(msg), ".ph "))
3279 sv_catpv(msg, " (did you run h2ph?)");
3280 sv_catpv(msg, " (@INC contains:");
3281 for (i = 0; i <= AvFILL(ar); i++) {
3282 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3283 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3284 sv_catsv(msg, dirmsgsv);
3286 sv_catpvn(msg, ")", 1);
3287 SvREFCNT_dec(dirmsgsv);
3288 msgstr = SvPV_nolen(msg);
3290 DIE(aTHX_ "Can't locate %s", msgstr);
3296 SETERRNO(0, SS$_NORMAL);
3298 /* Assume success here to prevent recursive requirement. */
3299 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3300 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3304 lex_start(sv_2mortal(newSVpvn("",0)));
3305 SAVEGENERICSV(PL_rsfp_filters);
3306 PL_rsfp_filters = Nullav;
3311 SAVESPTR(PL_compiling.cop_warnings);
3312 if (PL_dowarn & G_WARN_ALL_ON)
3313 PL_compiling.cop_warnings = pWARN_ALL ;
3314 else if (PL_dowarn & G_WARN_ALL_OFF)
3315 PL_compiling.cop_warnings = pWARN_NONE ;
3317 PL_compiling.cop_warnings = pWARN_STD ;
3318 SAVESPTR(PL_compiling.cop_io);
3319 PL_compiling.cop_io = Nullsv;
3321 if (filter_sub || filter_child_proc) {
3322 SV *datasv = filter_add(run_user_filter, Nullsv);
3323 IoLINES(datasv) = filter_has_file;
3324 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3325 IoTOP_GV(datasv) = (GV *)filter_state;
3326 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3329 /* switch to eval mode */
3330 push_return(PL_op->op_next);
3331 PUSHBLOCK(cx, CXt_EVAL, SP);
3332 PUSHEVAL(cx, name, Nullgv);
3334 SAVECOPLINE(&PL_compiling);
3335 CopLINE_set(&PL_compiling, 0);
3339 MUTEX_LOCK(&PL_eval_mutex);
3340 if (PL_eval_owner && PL_eval_owner != thr)
3341 while (PL_eval_owner)
3342 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3343 PL_eval_owner = thr;
3344 MUTEX_UNLOCK(&PL_eval_mutex);
3345 #endif /* USE_THREADS */
3346 return DOCATCH(doeval(G_SCALAR, NULL));
3351 return pp_require();
3357 register PERL_CONTEXT *cx;
3359 I32 gimme = GIMME_V, was = PL_sub_generation;
3360 char tbuf[TYPE_DIGITS(long) + 12];
3361 char *tmpbuf = tbuf;
3366 if (!SvPV(sv,len) || !len)
3368 TAINT_PROPER("eval");
3374 /* switch to eval mode */
3376 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3377 SV *sv = sv_newmortal();
3378 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3379 (unsigned long)++PL_evalseq,
3380 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3384 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3385 SAVECOPFILE_FREE(&PL_compiling);
3386 CopFILE_set(&PL_compiling, tmpbuf+2);
3387 SAVECOPLINE(&PL_compiling);
3388 CopLINE_set(&PL_compiling, 1);
3389 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3390 deleting the eval's FILEGV from the stash before gv_check() runs
3391 (i.e. before run-time proper). To work around the coredump that
3392 ensues, we always turn GvMULTI_on for any globals that were
3393 introduced within evals. See force_ident(). GSAR 96-10-12 */
3394 safestr = savepv(tmpbuf);
3395 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3397 PL_hints = PL_op->op_targ;
3398 SAVESPTR(PL_compiling.cop_warnings);
3399 if (specialWARN(PL_curcop->cop_warnings))
3400 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3402 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3403 SAVEFREESV(PL_compiling.cop_warnings);
3405 SAVESPTR(PL_compiling.cop_io);
3406 if (specialCopIO(PL_curcop->cop_io))
3407 PL_compiling.cop_io = PL_curcop->cop_io;
3409 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3410 SAVEFREESV(PL_compiling.cop_io);
3413 push_return(PL_op->op_next);
3414 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3415 PUSHEVAL(cx, 0, Nullgv);
3417 /* prepare to compile string */
3419 if (PERLDB_LINE && PL_curstash != PL_debstash)
3420 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3423 MUTEX_LOCK(&PL_eval_mutex);
3424 if (PL_eval_owner && PL_eval_owner != thr)
3425 while (PL_eval_owner)
3426 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3427 PL_eval_owner = thr;
3428 MUTEX_UNLOCK(&PL_eval_mutex);
3429 #endif /* USE_THREADS */
3430 ret = doeval(gimme, NULL);
3431 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3432 && ret != PL_op->op_next) { /* Successive compilation. */
3433 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3435 return DOCATCH(ret);
3445 register PERL_CONTEXT *cx;
3447 U8 save_flags = PL_op -> op_flags;
3452 retop = pop_return();
3455 if (gimme == G_VOID)
3457 else if (gimme == G_SCALAR) {
3460 if (SvFLAGS(TOPs) & SVs_TEMP)
3463 *MARK = sv_mortalcopy(TOPs);
3467 *MARK = &PL_sv_undef;
3472 /* in case LEAVE wipes old return values */
3473 for (mark = newsp + 1; mark <= SP; mark++) {
3474 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3475 *mark = sv_mortalcopy(*mark);
3476 TAINT_NOT; /* Each item is independent */
3480 PL_curpm = newpm; /* Don't pop $1 et al till now */
3482 if (AvFILLp(PL_comppad_name) >= 0)
3486 assert(CvDEPTH(PL_compcv) == 1);
3488 CvDEPTH(PL_compcv) = 0;
3491 if (optype == OP_REQUIRE &&
3492 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3494 /* Unassume the success we assumed earlier. */
3495 SV *nsv = cx->blk_eval.old_namesv;
3496 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3497 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3498 /* die_where() did LEAVE, or we won't be here */
3502 if (!(save_flags & OPf_SPECIAL))
3512 register PERL_CONTEXT *cx;
3513 I32 gimme = GIMME_V;
3518 push_return(cLOGOP->op_other->op_next);
3519 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3521 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3523 PL_in_eval = EVAL_INEVAL;
3526 return DOCATCH(PL_op->op_next);
3536 register PERL_CONTEXT *cx;
3544 if (gimme == G_VOID)
3546 else if (gimme == G_SCALAR) {
3549 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3552 *MARK = sv_mortalcopy(TOPs);
3556 *MARK = &PL_sv_undef;
3561 /* in case LEAVE wipes old return values */
3562 for (mark = newsp + 1; mark <= SP; mark++) {
3563 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3564 *mark = sv_mortalcopy(*mark);
3565 TAINT_NOT; /* Each item is independent */
3569 PL_curpm = newpm; /* Don't pop $1 et al till now */
3577 S_doparseform(pTHX_ SV *sv)
3580 register char *s = SvPV_force(sv, len);
3581 register char *send = s + len;
3582 register char *base;
3583 register I32 skipspaces = 0;
3586 bool postspace = FALSE;
3594 Perl_croak(aTHX_ "Null picture in formline");
3596 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3601 *fpc++ = FF_LINEMARK;
3602 noblank = repeat = FALSE;
3620 case ' ': case '\t':
3631 *fpc++ = FF_LITERAL;
3639 *fpc++ = skipspaces;
3643 *fpc++ = FF_NEWLINE;
3647 arg = fpc - linepc + 1;
3654 *fpc++ = FF_LINEMARK;
3655 noblank = repeat = FALSE;
3664 ischop = s[-1] == '^';
3670 arg = (s - base) - 1;
3672 *fpc++ = FF_LITERAL;
3681 *fpc++ = FF_LINEGLOB;
3683 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3684 arg = ischop ? 512 : 0;
3694 arg |= 256 + (s - f);
3696 *fpc++ = s - base; /* fieldsize for FETCH */
3697 *fpc++ = FF_DECIMAL;
3700 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3701 arg = ischop ? 512 : 0;
3703 s++; /* skip the '0' first */
3712 arg |= 256 + (s - f);
3714 *fpc++ = s - base; /* fieldsize for FETCH */
3715 *fpc++ = FF_0DECIMAL;
3720 bool ismore = FALSE;
3723 while (*++s == '>') ;
3724 prespace = FF_SPACE;
3726 else if (*s == '|') {
3727 while (*++s == '|') ;
3728 prespace = FF_HALFSPACE;
3733 while (*++s == '<') ;
3736 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3740 *fpc++ = s - base; /* fieldsize for FETCH */
3742 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3760 { /* need to jump to the next word */
3762 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3763 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3764 s = SvPVX(sv) + SvCUR(sv) + z;
3766 Copy(fops, s, arg, U16);
3768 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3773 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3775 * The original code was written in conjunction with BSD Computer Software
3776 * Research Group at University of California, Berkeley.
3778 * See also: "Optimistic Merge Sort" (SODA '92)
3780 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3782 * The code can be distributed under the same terms as Perl itself.
3787 #include <sys/types.h>
3792 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3793 #define Safefree(VAR) free(VAR)
3794 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3795 #endif /* TESTHARNESS */
3797 typedef char * aptr; /* pointer for arithmetic on sizes */
3798 typedef SV * gptr; /* pointers in our lists */
3800 /* Binary merge internal sort, with a few special mods
3801 ** for the special perl environment it now finds itself in.
3803 ** Things that were once options have been hotwired
3804 ** to values suitable for this use. In particular, we'll always
3805 ** initialize looking for natural runs, we'll always produce stable
3806 ** output, and we'll always do Peter McIlroy's binary merge.
3809 /* Pointer types for arithmetic and storage and convenience casts */
3811 #define APTR(P) ((aptr)(P))
3812 #define GPTP(P) ((gptr *)(P))
3813 #define GPPP(P) ((gptr **)(P))
3816 /* byte offset from pointer P to (larger) pointer Q */
3817 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3819 #define PSIZE sizeof(gptr)
3821 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3824 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3825 #define PNBYTE(N) ((N) << (PSHIFT))
3826 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3828 /* Leave optimization to compiler */
3829 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3830 #define PNBYTE(N) ((N) * (PSIZE))
3831 #define PINDEX(P, N) (GPTP(P) + (N))
3834 /* Pointer into other corresponding to pointer into this */
3835 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3837 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3840 /* Runs are identified by a pointer in the auxilliary list.
3841 ** The pointer is at the start of the list,
3842 ** and it points to the start of the next list.
3843 ** NEXT is used as an lvalue, too.
3846 #define NEXT(P) (*GPPP(P))
3849 /* PTHRESH is the minimum number of pairs with the same sense to justify
3850 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3851 ** not just elements, so PTHRESH == 8 means a run of 16.
3856 /* RTHRESH is the number of elements in a run that must compare low
3857 ** to the low element from the opposing run before we justify
3858 ** doing a binary rampup instead of single stepping.
3859 ** In random input, N in a row low should only happen with
3860 ** probability 2^(1-N), so we can risk that we are dealing
3861 ** with orderly input without paying much when we aren't.
3868 ** Overview of algorithm and variables.
3869 ** The array of elements at list1 will be organized into runs of length 2,
3870 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3871 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3873 ** Unless otherwise specified, pair pointers address the first of two elements.
3875 ** b and b+1 are a pair that compare with sense ``sense''.
3876 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3878 ** p2 parallels b in the list2 array, where runs are defined by
3881 ** t represents the ``top'' of the adjacent pairs that might extend
3882 ** the run beginning at b. Usually, t addresses a pair
3883 ** that compares with opposite sense from (b,b+1).
3884 ** However, it may also address a singleton element at the end of list1,
3885 ** or it may be equal to ``last'', the first element beyond list1.
3887 ** r addresses the Nth pair following b. If this would be beyond t,
3888 ** we back it off to t. Only when r is less than t do we consider the
3889 ** run long enough to consider checking.
3891 ** q addresses a pair such that the pairs at b through q already form a run.
3892 ** Often, q will equal b, indicating we only are sure of the pair itself.
3893 ** However, a search on the previous cycle may have revealed a longer run,
3894 ** so q may be greater than b.
3896 ** p is used to work back from a candidate r, trying to reach q,
3897 ** which would mean b through r would be a run. If we discover such a run,
3898 ** we start q at r and try to push it further towards t.
3899 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3900 ** In any event, after the check (if any), we have two main cases.
3902 ** 1) Short run. b <= q < p <= r <= t.
3903 ** b through q is a run (perhaps trivial)
3904 ** q through p are uninteresting pairs
3905 ** p through r is a run
3907 ** 2) Long run. b < r <= q < t.
3908 ** b through q is a run (of length >= 2 * PTHRESH)
3910 ** Note that degenerate cases are not only possible, but likely.
3911 ** For example, if the pair following b compares with opposite sense,
3912 ** then b == q < p == r == t.
3917 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3920 register gptr *b, *p, *q, *t, *p2;
3921 register gptr c, *last, *r;
3925 last = PINDEX(b, nmemb);
3926 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3927 for (p2 = list2; b < last; ) {
3928 /* We just started, or just reversed sense.
3929 ** Set t at end of pairs with the prevailing sense.
3931 for (p = b+2, t = p; ++p < last; t = ++p) {
3932 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3935 /* Having laid out the playing field, look for long runs */
3937 p = r = b + (2 * PTHRESH);
3938 if (r >= t) p = r = t; /* too short to care about */
3940 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3943 /* b through r is a (long) run.
3944 ** Extend it as far as possible.
3947 while (((p += 2) < t) &&
3948 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3949 r = p = q + 2; /* no simple pairs, no after-run */
3952 if (q > b) { /* run of greater than 2 at b */
3955 /* pick up singleton, if possible */
3957 ((t + 1) == last) &&
3958 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3959 savep = r = p = q = last;
3960 p2 = NEXT(p2) = p2 + (p - b);
3961 if (sense) while (b < --p) {
3968 while (q < p) { /* simple pairs */
3969 p2 = NEXT(p2) = p2 + 2;
3976 if (((b = p) == t) && ((t+1) == last)) {
3988 /* Overview of bmerge variables:
3990 ** list1 and list2 address the main and auxiliary arrays.
3991 ** They swap identities after each merge pass.
3992 ** Base points to the original list1, so we can tell if
3993 ** the pointers ended up where they belonged (or must be copied).
3995 ** When we are merging two lists, f1 and f2 are the next elements
3996 ** on the respective lists. l1 and l2 mark the end of the lists.
3997 ** tp2 is the current location in the merged list.
3999 ** p1 records where f1 started.
4000 ** After the merge, a new descriptor is built there.
4002 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4003 ** It is used to identify and delimit the runs.
4005 ** In the heat of determining where q, the greater of the f1/f2 elements,
4006 ** belongs in the other list, b, t and p, represent bottom, top and probe
4007 ** locations, respectively, in the other list.
4008 ** They make convenient temporary pointers in other places.
4012 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4016 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4017 gptr *aux, *list2, *p2, *last;
4021 if (nmemb <= 1) return; /* sorted trivially */
4022 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4024 dynprep(aTHX_ list1, list2, nmemb, cmp);
4025 last = PINDEX(list2, nmemb);
4026 while (NEXT(list2) != last) {
4027 /* More than one run remains. Do some merging to reduce runs. */
4029 for (tp2 = p2 = list2; p2 != last;) {
4030 /* The new first run begins where the old second list ended.
4031 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4035 f2 = l1 = POTHER(t, list2, list1);
4036 if (t != last) t = NEXT(t);
4037 l2 = POTHER(t, list2, list1);
4039 while (f1 < l1 && f2 < l2) {
4040 /* If head 1 is larger than head 2, find ALL the elements
4041 ** in list 2 strictly less than head1, write them all,
4042 ** then head 1. Then compare the new heads, and repeat,
4043 ** until one or both lists are exhausted.
4045 ** In all comparisons (after establishing
4046 ** which head to merge) the item to merge
4047 ** (at pointer q) is the first operand of
4048 ** the comparison. When we want to know
4049 ** if ``q is strictly less than the other'',
4051 ** cmp(q, other) < 0
4052 ** because stability demands that we treat equality
4053 ** as high when q comes from l2, and as low when
4054 ** q was from l1. So we ask the question by doing
4055 ** cmp(q, other) <= sense
4056 ** and make sense == 0 when equality should look low,
4057 ** and -1 when equality should look high.
4061 if (cmp(aTHX_ *f1, *f2) <= 0) {
4062 q = f2; b = f1; t = l1;
4065 q = f1; b = f2; t = l2;
4072 ** Leave t at something strictly
4073 ** greater than q (or at the end of the list),
4074 ** and b at something strictly less than q.
4076 for (i = 1, run = 0 ;;) {
4077 if ((p = PINDEX(b, i)) >= t) {
4079 if (((p = PINDEX(t, -1)) > b) &&
4080 (cmp(aTHX_ *q, *p) <= sense))
4084 } else if (cmp(aTHX_ *q, *p) <= sense) {
4088 if (++run >= RTHRESH) i += i;
4092 /* q is known to follow b and must be inserted before t.
4093 ** Increment b, so the range of possibilities is [b,t).
4094 ** Round binary split down, to favor early appearance.
4095 ** Adjust b and t until q belongs just before t.
4100 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4101 if (cmp(aTHX_ *q, *p) <= sense) {
4107 /* Copy all the strictly low elements */
4110 FROMTOUPTO(f2, tp2, t);
4113 FROMTOUPTO(f1, tp2, t);
4119 /* Run out remaining list */
4121 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4122 } else FROMTOUPTO(f1, tp2, l1);
4123 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4128 last = PINDEX(list2, nmemb);
4130 if (base == list2) {
4131 last = PINDEX(list1, nmemb);
4132 FROMTOUPTO(list1, list2, last);
4147 sortcv(pTHXo_ SV *a, SV *b)
4149 I32 oldsaveix = PL_savestack_ix;
4150 I32 oldscopeix = PL_scopestack_ix;
4152 GvSV(PL_firstgv) = a;
4153 GvSV(PL_secondgv) = b;
4154 PL_stack_sp = PL_stack_base;
4157 if (PL_stack_sp != PL_stack_base + 1)
4158 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4159 if (!SvNIOKp(*PL_stack_sp))
4160 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4161 result = SvIV(*PL_stack_sp);
4162 while (PL_scopestack_ix > oldscopeix) {
4165 leave_scope(oldsaveix);
4170 sortcv_stacked(pTHXo_ SV *a, SV *b)
4172 I32 oldsaveix = PL_savestack_ix;
4173 I32 oldscopeix = PL_scopestack_ix;
4178 av = (AV*)PL_curpad[0];
4180 av = GvAV(PL_defgv);
4183 if (AvMAX(av) < 1) {
4184 SV** ary = AvALLOC(av);
4185 if (AvARRAY(av) != ary) {
4186 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4187 SvPVX(av) = (char*)ary;
4189 if (AvMAX(av) < 1) {
4192 SvPVX(av) = (char*)ary;
4199 PL_stack_sp = PL_stack_base;
4202 if (PL_stack_sp != PL_stack_base + 1)
4203 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4204 if (!SvNIOKp(*PL_stack_sp))
4205 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4206 result = SvIV(*PL_stack_sp);
4207 while (PL_scopestack_ix > oldscopeix) {
4210 leave_scope(oldsaveix);
4215 sortcv_xsub(pTHXo_ SV *a, SV *b)
4218 I32 oldsaveix = PL_savestack_ix;
4219 I32 oldscopeix = PL_scopestack_ix;
4221 CV *cv=(CV*)PL_sortcop;
4229 (void)(*CvXSUB(cv))(aTHXo_ cv);
4230 if (PL_stack_sp != PL_stack_base + 1)
4231 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4232 if (!SvNIOKp(*PL_stack_sp))
4233 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4234 result = SvIV(*PL_stack_sp);
4235 while (PL_scopestack_ix > oldscopeix) {
4238 leave_scope(oldsaveix);
4244 sv_ncmp(pTHXo_ SV *a, SV *b)
4248 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4252 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4256 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4258 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4260 if (PL_amagic_generation) { \
4261 if (SvAMAGIC(left)||SvAMAGIC(right))\
4262 *svp = amagic_call(left, \
4270 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4273 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4278 I32 i = SvIVX(tmpsv);
4288 return sv_ncmp(aTHXo_ a, b);
4292 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4295 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4300 I32 i = SvIVX(tmpsv);
4310 return sv_i_ncmp(aTHXo_ a, b);
4314 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4317 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4322 I32 i = SvIVX(tmpsv);
4332 return sv_cmp(str1, str2);
4336 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4339 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4344 I32 i = SvIVX(tmpsv);
4354 return sv_cmp_locale(str1, str2);
4358 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4360 SV *datasv = FILTER_DATA(idx);
4361 int filter_has_file = IoLINES(datasv);
4362 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4363 SV *filter_state = (SV *)IoTOP_GV(datasv);
4364 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4367 /* I was having segfault trouble under Linux 2.2.5 after a
4368 parse error occured. (Had to hack around it with a test
4369 for PL_error_count == 0.) Solaris doesn't segfault --
4370 not sure where the trouble is yet. XXX */
4372 if (filter_has_file) {
4373 len = FILTER_READ(idx+1, buf_sv, maxlen);
4376 if (filter_sub && len >= 0) {
4387 PUSHs(sv_2mortal(newSViv(maxlen)));
4389 PUSHs(filter_state);
4392 count = call_sv(filter_sub, G_SCALAR);
4408 IoLINES(datasv) = 0;
4409 if (filter_child_proc) {
4410 SvREFCNT_dec(filter_child_proc);
4411 IoFMT_GV(datasv) = Nullgv;
4414 SvREFCNT_dec(filter_state);
4415 IoTOP_GV(datasv) = Nullgv;
4418 SvREFCNT_dec(filter_sub);
4419 IoBOTTOM_GV(datasv) = Nullgv;
4421 filter_del(run_user_filter);
4430 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4432 return sv_cmp_locale(str1, str2);
4436 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4438 return sv_cmp(str1, str2);
4441 #endif /* PERL_OBJECT */