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;
345 case FF_0DECIMAL: name = "0DECIMAL"; break;
348 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
350 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
378 if (ckWARN(WARN_SYNTAX))
379 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
384 item = s = SvPV(sv, len);
387 itemsize = sv_len_utf8(sv);
388 if (itemsize != len) {
390 if (itemsize > fieldsize) {
391 itemsize = fieldsize;
392 itembytes = itemsize;
393 sv_pos_u2b(sv, &itembytes, 0);
397 send = chophere = s + itembytes;
407 sv_pos_b2u(sv, &itemsize);
412 if (itemsize > fieldsize)
413 itemsize = fieldsize;
414 send = chophere = s + itemsize;
426 item = s = SvPV(sv, len);
429 itemsize = sv_len_utf8(sv);
430 if (itemsize != len) {
432 if (itemsize <= fieldsize) {
433 send = chophere = s + itemsize;
444 itemsize = fieldsize;
445 itembytes = itemsize;
446 sv_pos_u2b(sv, &itembytes, 0);
447 send = chophere = s + itembytes;
448 while (s < send || (s == send && isSPACE(*s))) {
458 if (strchr(PL_chopset, *s))
463 itemsize = chophere - item;
464 sv_pos_b2u(sv, &itemsize);
471 if (itemsize <= fieldsize) {
472 send = chophere = s + itemsize;
483 itemsize = fieldsize;
484 send = chophere = s + itemsize;
485 while (s < send || (s == send && isSPACE(*s))) {
495 if (strchr(PL_chopset, *s))
500 itemsize = chophere - item;
505 arg = fieldsize - itemsize;
514 arg = fieldsize - itemsize;
529 switch (UTF8SKIP(s)) {
540 if ( !((*t++ = *s++) & ~31) )
548 int ch = *t++ = *s++;
551 if ( !((*t++ = *s++) & ~31) )
560 while (*s && isSPACE(*s))
567 item = s = SvPV(sv, len);
569 item_is_utf = FALSE; /* XXX is this correct? */
581 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
582 sv_catpvn(PL_formtarget, item, itemsize);
583 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
584 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
589 /* If the field is marked with ^ and the value is undefined,
592 if ((arg & 512) && !SvOK(sv)) {
600 /* Formats aren't yet marked for locales, so assume "yes". */
602 STORE_NUMERIC_STANDARD_SET_LOCAL();
603 #if defined(USE_LONG_DOUBLE)
605 sprintf(t, "%#*.*" PERL_PRIfldbl,
606 (int) fieldsize, (int) arg & 255, value);
608 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
613 (int) fieldsize, (int) arg & 255, value);
616 (int) fieldsize, value);
619 RESTORE_NUMERIC_STANDARD();
625 /* If the field is marked with ^ and the value is undefined,
628 if ((arg & 512) && !SvOK(sv)) {
636 /* Formats aren't yet marked for locales, so assume "yes". */
638 STORE_NUMERIC_STANDARD_SET_LOCAL();
639 #if defined(USE_LONG_DOUBLE)
641 sprintf(t, "%#0*.*" PERL_PRIfldbl,
642 (int) fieldsize, (int) arg & 255, value);
643 /* is this legal? I don't have long doubles */
645 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
649 sprintf(t, "%#0*.*f",
650 (int) fieldsize, (int) arg & 255, value);
653 (int) fieldsize, value);
656 RESTORE_NUMERIC_STANDARD();
663 while (t-- > linemark && *t == ' ') ;
671 if (arg) { /* repeat until fields exhausted? */
673 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
674 lines += FmLINES(PL_formtarget);
677 if (strnEQ(linemark, linemark - arg, arg))
678 DIE(aTHX_ "Runaway format");
680 FmLINES(PL_formtarget) = lines;
682 RETURNOP(cLISTOP->op_first);
695 while (*s && isSPACE(*s) && s < send)
699 arg = fieldsize - itemsize;
706 if (strnEQ(s," ",3)) {
707 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
718 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
719 FmLINES(PL_formtarget) += lines;
731 if (PL_stack_base + *PL_markstack_ptr == SP) {
733 if (GIMME_V == G_SCALAR)
734 XPUSHs(sv_2mortal(newSViv(0)));
735 RETURNOP(PL_op->op_next->op_next);
737 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
738 pp_pushmark(); /* push dst */
739 pp_pushmark(); /* push src */
740 ENTER; /* enter outer scope */
743 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
745 ENTER; /* enter inner scope */
748 src = PL_stack_base[*PL_markstack_ptr];
753 if (PL_op->op_type == OP_MAPSTART)
754 pp_pushmark(); /* push top */
755 return ((LOGOP*)PL_op->op_next)->op_other;
760 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
766 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
772 /* first, move source pointer to the next item in the source list */
773 ++PL_markstack_ptr[-1];
775 /* if there are new items, push them into the destination list */
777 /* might need to make room back there first */
778 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
779 /* XXX this implementation is very pessimal because the stack
780 * is repeatedly extended for every set of items. Is possible
781 * to do this without any stack extension or copying at all
782 * by maintaining a separate list over which the map iterates
783 * (like foreach does). --gsar */
785 /* everything in the stack after the destination list moves
786 * towards the end the stack by the amount of room needed */
787 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
789 /* items to shift up (accounting for the moved source pointer) */
790 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
792 /* This optimization is by Ben Tilly and it does
793 * things differently from what Sarathy (gsar)
794 * is describing. The downside of this optimization is
795 * that leaves "holes" (uninitialized and hopefully unused areas)
796 * to the Perl stack, but on the other hand this
797 * shouldn't be a problem. If Sarathy's idea gets
798 * implemented, this optimization should become
799 * irrelevant. --jhi */
801 shift = count; /* Avoid shifting too often --Ben Tilly */
806 PL_markstack_ptr[-1] += shift;
807 *PL_markstack_ptr += shift;
811 /* copy the new items down to the destination list */
812 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
814 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
816 LEAVE; /* exit inner scope */
819 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
822 (void)POPMARK; /* pop top */
823 LEAVE; /* exit outer scope */
824 (void)POPMARK; /* pop src */
825 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
826 (void)POPMARK; /* pop dst */
827 SP = PL_stack_base + POPMARK; /* pop original mark */
828 if (gimme == G_SCALAR) {
832 else if (gimme == G_ARRAY)
839 ENTER; /* enter inner scope */
842 /* set $_ to the new source item */
843 src = PL_stack_base[PL_markstack_ptr[-1]];
847 RETURNOP(cLOGOP->op_other);
853 djSP; dMARK; dORIGMARK;
855 SV **myorigmark = ORIGMARK;
861 OP* nextop = PL_op->op_next;
863 bool hasargs = FALSE;
866 if (gimme != G_ARRAY) {
872 SAVEVPTR(PL_sortcop);
873 if (PL_op->op_flags & OPf_STACKED) {
874 if (PL_op->op_flags & OPf_SPECIAL) {
875 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
876 kid = kUNOP->op_first; /* pass rv2gv */
877 kid = kUNOP->op_first; /* pass leave */
878 PL_sortcop = kid->op_next;
879 stash = CopSTASH(PL_curcop);
882 cv = sv_2cv(*++MARK, &stash, &gv, 0);
883 if (cv && SvPOK(cv)) {
885 char *proto = SvPV((SV*)cv, n_a);
886 if (proto && strEQ(proto, "$$")) {
890 if (!(cv && CvROOT(cv))) {
891 if (cv && CvXSUB(cv)) {
895 SV *tmpstr = sv_newmortal();
896 gv_efullname3(tmpstr, gv, Nullch);
897 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
901 DIE(aTHX_ "Undefined subroutine in sort");
906 PL_sortcop = (OP*)cv;
908 PL_sortcop = CvSTART(cv);
909 SAVEVPTR(CvROOT(cv)->op_ppaddr);
910 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
913 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
919 stash = CopSTASH(PL_curcop);
923 while (MARK < SP) { /* This may or may not shift down one here. */
925 if ((*up = *++MARK)) { /* Weed out nulls. */
927 if (!PL_sortcop && !SvPOK(*up)) {
932 (void)sv_2pv(*up, &n_a);
937 max = --up - myorigmark;
942 bool oldcatch = CATCH_GET;
948 PUSHSTACKi(PERLSI_SORT);
949 if (!hasargs && !is_xsub) {
950 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
951 SAVESPTR(PL_firstgv);
952 SAVESPTR(PL_secondgv);
953 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
954 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
955 PL_sortstash = stash;
958 sv_lock((SV *)PL_firstgv);
959 sv_lock((SV *)PL_secondgv);
961 SAVESPTR(GvSV(PL_firstgv));
962 SAVESPTR(GvSV(PL_secondgv));
965 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
966 if (!(PL_op->op_flags & OPf_SPECIAL)) {
967 cx->cx_type = CXt_SUB;
968 cx->blk_gimme = G_SCALAR;
971 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
973 PL_sortcxix = cxstack_ix;
975 if (hasargs && !is_xsub) {
976 /* This is mostly copied from pp_entersub */
977 AV *av = (AV*)PL_curpad[0];
980 cx->blk_sub.savearray = GvAV(PL_defgv);
981 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
982 #endif /* USE_THREADS */
983 cx->blk_sub.oldcurpad = PL_curpad;
984 cx->blk_sub.argarray = av;
986 qsortsv((myorigmark+1), max,
987 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
989 POPBLOCK(cx,PL_curpm);
997 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
998 qsortsv(ORIGMARK+1, max,
999 (PL_op->op_private & OPpSORT_NUMERIC)
1000 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1001 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1002 : ( overloading ? amagic_ncmp : sv_ncmp))
1003 : ( (PL_op->op_private & OPpLOCALE)
1006 : sv_cmp_locale_static)
1007 : ( overloading ? amagic_cmp : sv_cmp_static)));
1008 if (PL_op->op_private & OPpSORT_REVERSE) {
1009 SV **p = ORIGMARK+1;
1010 SV **q = ORIGMARK+max;
1020 PL_stack_sp = ORIGMARK + max;
1028 if (GIMME == G_ARRAY)
1030 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1031 return cLOGOP->op_other;
1040 if (GIMME == G_ARRAY) {
1041 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1045 SV *targ = PAD_SV(PL_op->op_targ);
1048 if (PL_op->op_private & OPpFLIP_LINENUM) {
1050 flip = PL_last_in_gv
1051 && (gp_io = GvIOp(PL_last_in_gv))
1052 && SvIV(sv) == (IV)IoLINES(gp_io);
1057 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1058 if (PL_op->op_flags & OPf_SPECIAL) {
1066 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1079 if (GIMME == G_ARRAY) {
1085 if (SvGMAGICAL(left))
1087 if (SvGMAGICAL(right))
1090 if (SvNIOKp(left) || !SvPOKp(left) ||
1091 SvNIOKp(right) || !SvPOKp(right) ||
1092 (looks_like_number(left) && *SvPVX(left) != '0' &&
1093 looks_like_number(right) && *SvPVX(right) != '0'))
1095 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1096 DIE(aTHX_ "Range iterator outside integer range");
1107 sv = sv_2mortal(newSViv(i++));
1112 SV *final = sv_mortalcopy(right);
1114 char *tmps = SvPV(final, len);
1116 sv = sv_mortalcopy(left);
1118 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1120 if (strEQ(SvPVX(sv),tmps))
1122 sv = sv_2mortal(newSVsv(sv));
1129 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1131 if ((PL_op->op_private & OPpFLIP_LINENUM)
1132 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1134 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1135 sv_catpv(targ, "E0");
1146 S_dopoptolabel(pTHX_ char *label)
1150 register PERL_CONTEXT *cx;
1152 for (i = cxstack_ix; i >= 0; i--) {
1154 switch (CxTYPE(cx)) {
1156 if (ckWARN(WARN_EXITING))
1157 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1158 PL_op_name[PL_op->op_type]);
1161 if (ckWARN(WARN_EXITING))
1162 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1163 PL_op_name[PL_op->op_type]);
1166 if (ckWARN(WARN_EXITING))
1167 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1168 PL_op_name[PL_op->op_type]);
1171 if (ckWARN(WARN_EXITING))
1172 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1173 PL_op_name[PL_op->op_type]);
1176 if (ckWARN(WARN_EXITING))
1177 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1178 PL_op_name[PL_op->op_type]);
1181 if (!cx->blk_loop.label ||
1182 strNE(label, cx->blk_loop.label) ) {
1183 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1184 (long)i, cx->blk_loop.label));
1187 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1195 Perl_dowantarray(pTHX)
1197 I32 gimme = block_gimme();
1198 return (gimme == G_VOID) ? G_SCALAR : gimme;
1202 Perl_block_gimme(pTHX)
1207 cxix = dopoptosub(cxstack_ix);
1211 switch (cxstack[cxix].blk_gimme) {
1219 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1226 S_dopoptosub(pTHX_ I32 startingblock)
1229 return dopoptosub_at(cxstack, startingblock);
1233 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1237 register PERL_CONTEXT *cx;
1238 for (i = startingblock; i >= 0; i--) {
1240 switch (CxTYPE(cx)) {
1246 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1254 S_dopoptoeval(pTHX_ I32 startingblock)
1258 register PERL_CONTEXT *cx;
1259 for (i = startingblock; i >= 0; i--) {
1261 switch (CxTYPE(cx)) {
1265 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1273 S_dopoptoloop(pTHX_ I32 startingblock)
1277 register PERL_CONTEXT *cx;
1278 for (i = startingblock; i >= 0; i--) {
1280 switch (CxTYPE(cx)) {
1282 if (ckWARN(WARN_EXITING))
1283 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1284 PL_op_name[PL_op->op_type]);
1287 if (ckWARN(WARN_EXITING))
1288 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1289 PL_op_name[PL_op->op_type]);
1292 if (ckWARN(WARN_EXITING))
1293 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1294 PL_op_name[PL_op->op_type]);
1297 if (ckWARN(WARN_EXITING))
1298 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1299 PL_op_name[PL_op->op_type]);
1302 if (ckWARN(WARN_EXITING))
1303 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1304 PL_op_name[PL_op->op_type]);
1307 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1315 Perl_dounwind(pTHX_ I32 cxix)
1318 register PERL_CONTEXT *cx;
1321 while (cxstack_ix > cxix) {
1323 cx = &cxstack[cxstack_ix];
1324 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1325 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1326 /* Note: we don't need to restore the base context info till the end. */
1327 switch (CxTYPE(cx)) {
1330 continue; /* not break */
1352 * Closures mentioned at top level of eval cannot be referenced
1353 * again, and their presence indirectly causes a memory leak.
1354 * (Note that the fact that compcv and friends are still set here
1355 * is, AFAIK, an accident.) --Chip
1357 * XXX need to get comppad et al from eval's cv rather than
1358 * relying on the incidental global values.
1361 S_free_closures(pTHX)
1364 SV **svp = AvARRAY(PL_comppad_name);
1366 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1368 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1370 svp[ix] = &PL_sv_undef;
1374 SvREFCNT_dec(CvOUTSIDE(sv));
1375 CvOUTSIDE(sv) = Nullcv;
1388 Perl_qerror(pTHX_ SV *err)
1391 sv_catsv(ERRSV, err);
1393 sv_catsv(PL_errors, err);
1395 Perl_warn(aTHX_ "%"SVf, err);
1400 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1405 register PERL_CONTEXT *cx;
1410 if (PL_in_eval & EVAL_KEEPERR) {
1411 static char prefix[] = "\t(in cleanup) ";
1416 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1419 if (*e != *message || strNE(e,message))
1423 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1424 sv_catpvn(err, prefix, sizeof(prefix)-1);
1425 sv_catpvn(err, message, msglen);
1426 if (ckWARN(WARN_MISC)) {
1427 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1428 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1433 sv_setpvn(ERRSV, message, msglen);
1436 message = SvPVx(ERRSV, msglen);
1438 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1439 && PL_curstackinfo->si_prev)
1448 if (cxix < cxstack_ix)
1451 POPBLOCK(cx,PL_curpm);
1452 if (CxTYPE(cx) != CXt_EVAL) {
1453 PerlIO_write(Perl_error_log, "panic: die ", 11);
1454 PerlIO_write(Perl_error_log, message, msglen);
1459 if (gimme == G_SCALAR)
1460 *++newsp = &PL_sv_undef;
1461 PL_stack_sp = newsp;
1465 /* LEAVE could clobber PL_curcop (see save_re_context())
1466 * XXX it might be better to find a way to avoid messing with
1467 * PL_curcop in save_re_context() instead, but this is a more
1468 * minimal fix --GSAR */
1469 PL_curcop = cx->blk_oldcop;
1471 if (optype == OP_REQUIRE) {
1472 char* msg = SvPVx(ERRSV, n_a);
1473 DIE(aTHX_ "%sCompilation failed in require",
1474 *msg ? msg : "Unknown error\n");
1476 return pop_return();
1480 message = SvPVx(ERRSV, msglen);
1483 /* SFIO can really mess with your errno */
1486 PerlIO *serr = Perl_error_log;
1488 PerlIO_write(serr, message, msglen);
1489 (void)PerlIO_flush(serr);
1502 if (SvTRUE(left) != SvTRUE(right))
1514 RETURNOP(cLOGOP->op_other);
1523 RETURNOP(cLOGOP->op_other);
1529 register I32 cxix = dopoptosub(cxstack_ix);
1530 register PERL_CONTEXT *cx;
1531 register PERL_CONTEXT *ccstack = cxstack;
1532 PERL_SI *top_si = PL_curstackinfo;
1543 /* we may be in a higher stacklevel, so dig down deeper */
1544 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1545 top_si = top_si->si_prev;
1546 ccstack = top_si->si_cxstack;
1547 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1550 if (GIMME != G_ARRAY)
1554 if (PL_DBsub && cxix >= 0 &&
1555 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1559 cxix = dopoptosub_at(ccstack, cxix - 1);
1562 cx = &ccstack[cxix];
1563 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1565 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1566 field below is defined for any cx. */
1567 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1568 cx = &ccstack[dbcxix];
1571 stashname = CopSTASHPV(cx->blk_oldcop);
1572 if (GIMME != G_ARRAY) {
1574 PUSHs(&PL_sv_undef);
1577 sv_setpv(TARG, stashname);
1584 PUSHs(&PL_sv_undef);
1586 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1587 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1588 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1591 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1592 /* So is ccstack[dbcxix]. */
1594 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1595 PUSHs(sv_2mortal(sv));
1596 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1599 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1600 PUSHs(sv_2mortal(newSViv(0)));
1602 gimme = (I32)cx->blk_gimme;
1603 if (gimme == G_VOID)
1604 PUSHs(&PL_sv_undef);
1606 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1607 if (CxTYPE(cx) == CXt_EVAL) {
1609 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1610 PUSHs(cx->blk_eval.cur_text);
1614 else if (cx->blk_eval.old_namesv) {
1615 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1618 /* eval BLOCK (try blocks have old_namesv == 0) */
1620 PUSHs(&PL_sv_undef);
1621 PUSHs(&PL_sv_undef);
1625 PUSHs(&PL_sv_undef);
1626 PUSHs(&PL_sv_undef);
1628 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1629 && CopSTASH_eq(PL_curcop, PL_debstash))
1631 AV *ary = cx->blk_sub.argarray;
1632 int off = AvARRAY(ary) - AvALLOC(ary);
1636 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1639 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1642 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1643 av_extend(PL_dbargs, AvFILLp(ary) + off);
1644 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1645 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1647 /* XXX only hints propagated via op_private are currently
1648 * visible (others are not easily accessible, since they
1649 * use the global PL_hints) */
1650 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1651 HINT_PRIVATE_MASK)));
1654 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1656 if (old_warnings == pWARN_NONE ||
1657 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1658 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1659 else if (old_warnings == pWARN_ALL ||
1660 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1661 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1663 mask = newSVsv(old_warnings);
1664 PUSHs(sv_2mortal(mask));
1679 sv_reset(tmps, CopSTASH(PL_curcop));
1691 PL_curcop = (COP*)PL_op;
1692 TAINT_NOT; /* Each statement is presumed innocent */
1693 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1696 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1700 register PERL_CONTEXT *cx;
1701 I32 gimme = G_ARRAY;
1708 DIE(aTHX_ "No DB::DB routine defined");
1710 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1722 push_return(PL_op->op_next);
1723 PUSHBLOCK(cx, CXt_SUB, SP);
1726 (void)SvREFCNT_inc(cv);
1727 SAVEVPTR(PL_curpad);
1728 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1729 RETURNOP(CvSTART(cv));
1743 register PERL_CONTEXT *cx;
1744 I32 gimme = GIMME_V;
1746 U32 cxtype = CXt_LOOP;
1755 if (PL_op->op_flags & OPf_SPECIAL) {
1757 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1758 SAVEGENERICSV(*svp);
1762 #endif /* USE_THREADS */
1763 if (PL_op->op_targ) {
1764 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1767 iterdata = (void*)PL_op->op_targ;
1768 cxtype |= CXp_PADVAR;
1773 svp = &GvSV(gv); /* symbol table variable */
1774 SAVEGENERICSV(*svp);
1777 iterdata = (void*)gv;
1783 PUSHBLOCK(cx, cxtype, SP);
1785 PUSHLOOP(cx, iterdata, MARK);
1787 PUSHLOOP(cx, svp, MARK);
1789 if (PL_op->op_flags & OPf_STACKED) {
1790 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1791 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1793 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1794 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1795 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1796 looks_like_number((SV*)cx->blk_loop.iterary) &&
1797 *SvPVX(cx->blk_loop.iterary) != '0'))
1799 if (SvNV(sv) < IV_MIN ||
1800 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1801 DIE(aTHX_ "Range iterator outside integer range");
1802 cx->blk_loop.iterix = SvIV(sv);
1803 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1806 cx->blk_loop.iterlval = newSVsv(sv);
1810 cx->blk_loop.iterary = PL_curstack;
1811 AvFILLp(PL_curstack) = SP - PL_stack_base;
1812 cx->blk_loop.iterix = MARK - PL_stack_base;
1821 register PERL_CONTEXT *cx;
1822 I32 gimme = GIMME_V;
1828 PUSHBLOCK(cx, CXt_LOOP, SP);
1829 PUSHLOOP(cx, 0, SP);
1837 register PERL_CONTEXT *cx;
1845 newsp = PL_stack_base + cx->blk_loop.resetsp;
1848 if (gimme == G_VOID)
1850 else if (gimme == G_SCALAR) {
1852 *++newsp = sv_mortalcopy(*SP);
1854 *++newsp = &PL_sv_undef;
1858 *++newsp = sv_mortalcopy(*++mark);
1859 TAINT_NOT; /* Each item is independent */
1865 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1866 PL_curpm = newpm; /* ... and pop $1 et al */
1878 register PERL_CONTEXT *cx;
1879 bool popsub2 = FALSE;
1880 bool clear_errsv = FALSE;
1887 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1888 if (cxstack_ix == PL_sortcxix
1889 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1891 if (cxstack_ix > PL_sortcxix)
1892 dounwind(PL_sortcxix);
1893 AvARRAY(PL_curstack)[1] = *SP;
1894 PL_stack_sp = PL_stack_base + 1;
1899 cxix = dopoptosub(cxstack_ix);
1901 DIE(aTHX_ "Can't return outside a subroutine");
1902 if (cxix < cxstack_ix)
1906 switch (CxTYPE(cx)) {
1911 if (!(PL_in_eval & EVAL_KEEPERR))
1916 if (AvFILLp(PL_comppad_name) >= 0)
1919 if (optype == OP_REQUIRE &&
1920 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1922 /* Unassume the success we assumed earlier. */
1923 SV *nsv = cx->blk_eval.old_namesv;
1924 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1925 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1932 DIE(aTHX_ "panic: return");
1936 if (gimme == G_SCALAR) {
1939 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1941 *++newsp = SvREFCNT_inc(*SP);
1946 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1948 *++newsp = sv_mortalcopy(sv);
1953 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1956 *++newsp = sv_mortalcopy(*SP);
1959 *++newsp = &PL_sv_undef;
1961 else if (gimme == G_ARRAY) {
1962 while (++MARK <= SP) {
1963 *++newsp = (popsub2 && SvTEMP(*MARK))
1964 ? *MARK : sv_mortalcopy(*MARK);
1965 TAINT_NOT; /* Each item is independent */
1968 PL_stack_sp = newsp;
1970 /* Stack values are safe: */
1972 POPSUB(cx,sv); /* release CV and @_ ... */
1976 PL_curpm = newpm; /* ... and pop $1 et al */
1982 return pop_return();
1989 register PERL_CONTEXT *cx;
1999 if (PL_op->op_flags & OPf_SPECIAL) {
2000 cxix = dopoptoloop(cxstack_ix);
2002 DIE(aTHX_ "Can't \"last\" outside a loop block");
2005 cxix = dopoptolabel(cPVOP->op_pv);
2007 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2009 if (cxix < cxstack_ix)
2014 switch (CxTYPE(cx)) {
2017 newsp = PL_stack_base + cx->blk_loop.resetsp;
2018 nextop = cx->blk_loop.last_op->op_next;
2022 nextop = pop_return();
2026 nextop = pop_return();
2030 nextop = pop_return();
2033 DIE(aTHX_ "panic: last");
2037 if (gimme == G_SCALAR) {
2039 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2040 ? *SP : sv_mortalcopy(*SP);
2042 *++newsp = &PL_sv_undef;
2044 else if (gimme == G_ARRAY) {
2045 while (++MARK <= SP) {
2046 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2047 ? *MARK : sv_mortalcopy(*MARK);
2048 TAINT_NOT; /* Each item is independent */
2054 /* Stack values are safe: */
2057 POPLOOP(cx); /* release loop vars ... */
2061 POPSUB(cx,sv); /* release CV and @_ ... */
2064 PL_curpm = newpm; /* ... and pop $1 et al */
2074 register PERL_CONTEXT *cx;
2077 if (PL_op->op_flags & OPf_SPECIAL) {
2078 cxix = dopoptoloop(cxstack_ix);
2080 DIE(aTHX_ "Can't \"next\" outside a loop block");
2083 cxix = dopoptolabel(cPVOP->op_pv);
2085 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2087 if (cxix < cxstack_ix)
2090 /* clear off anything above the scope we're re-entering, but
2091 * save the rest until after a possible continue block */
2092 inner = PL_scopestack_ix;
2094 if (PL_scopestack_ix < inner)
2095 leave_scope(PL_scopestack[PL_scopestack_ix]);
2096 return cx->blk_loop.next_op;
2102 register PERL_CONTEXT *cx;
2105 if (PL_op->op_flags & OPf_SPECIAL) {
2106 cxix = dopoptoloop(cxstack_ix);
2108 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2111 cxix = dopoptolabel(cPVOP->op_pv);
2113 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2115 if (cxix < cxstack_ix)
2119 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2120 LEAVE_SCOPE(oldsave);
2121 return cx->blk_loop.redo_op;
2125 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2129 static char too_deep[] = "Target of goto is too deeply nested";
2132 Perl_croak(aTHX_ too_deep);
2133 if (o->op_type == OP_LEAVE ||
2134 o->op_type == OP_SCOPE ||
2135 o->op_type == OP_LEAVELOOP ||
2136 o->op_type == OP_LEAVETRY)
2138 *ops++ = cUNOPo->op_first;
2140 Perl_croak(aTHX_ too_deep);
2143 if (o->op_flags & OPf_KIDS) {
2145 /* First try all the kids at this level, since that's likeliest. */
2146 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2147 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2148 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2151 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2152 if (kid == PL_lastgotoprobe)
2154 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2156 (ops[-1]->op_type != OP_NEXTSTATE &&
2157 ops[-1]->op_type != OP_DBSTATE)))
2159 if ((o = dofindlabel(kid, label, ops, oplimit)))
2178 register PERL_CONTEXT *cx;
2179 #define GOTO_DEPTH 64
2180 OP *enterops[GOTO_DEPTH];
2182 int do_dump = (PL_op->op_type == OP_DUMP);
2183 static char must_have_label[] = "goto must have label";
2186 if (PL_op->op_flags & OPf_STACKED) {
2190 /* This egregious kludge implements goto &subroutine */
2191 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2193 register PERL_CONTEXT *cx;
2194 CV* cv = (CV*)SvRV(sv);
2200 if (!CvROOT(cv) && !CvXSUB(cv)) {
2205 /* autoloaded stub? */
2206 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2208 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2209 GvNAMELEN(gv), FALSE);
2210 if (autogv && (cv = GvCV(autogv)))
2212 tmpstr = sv_newmortal();
2213 gv_efullname3(tmpstr, gv, Nullch);
2214 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2216 DIE(aTHX_ "Goto undefined subroutine");
2219 /* First do some returnish stuff. */
2220 cxix = dopoptosub(cxstack_ix);
2222 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2223 if (cxix < cxstack_ix)
2226 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2227 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2229 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2230 /* put @_ back onto stack */
2231 AV* av = cx->blk_sub.argarray;
2233 items = AvFILLp(av) + 1;
2235 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2236 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2237 PL_stack_sp += items;
2239 SvREFCNT_dec(GvAV(PL_defgv));
2240 GvAV(PL_defgv) = cx->blk_sub.savearray;
2241 #endif /* USE_THREADS */
2242 /* abandon @_ if it got reified */
2244 (void)sv_2mortal((SV*)av); /* delay until return */
2246 av_extend(av, items-1);
2247 AvFLAGS(av) = AVf_REIFY;
2248 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2251 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2254 av = (AV*)PL_curpad[0];
2256 av = GvAV(PL_defgv);
2258 items = AvFILLp(av) + 1;
2260 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2261 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2262 PL_stack_sp += items;
2264 if (CxTYPE(cx) == CXt_SUB &&
2265 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2266 SvREFCNT_dec(cx->blk_sub.cv);
2267 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2268 LEAVE_SCOPE(oldsave);
2270 /* Now do some callish stuff. */
2273 #ifdef PERL_XSUB_OLDSTYLE
2274 if (CvOLDSTYLE(cv)) {
2275 I32 (*fp3)(int,int,int);
2280 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2281 items = (*fp3)(CvXSUBANY(cv).any_i32,
2282 mark - PL_stack_base + 1,
2284 SP = PL_stack_base + items;
2287 #endif /* PERL_XSUB_OLDSTYLE */
2292 PL_stack_sp--; /* There is no cv arg. */
2293 /* Push a mark for the start of arglist */
2295 (void)(*CvXSUB(cv))(aTHXo_ cv);
2296 /* Pop the current context like a decent sub should */
2297 POPBLOCK(cx, PL_curpm);
2298 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2301 return pop_return();
2304 AV* padlist = CvPADLIST(cv);
2305 SV** svp = AvARRAY(padlist);
2306 if (CxTYPE(cx) == CXt_EVAL) {
2307 PL_in_eval = cx->blk_eval.old_in_eval;
2308 PL_eval_root = cx->blk_eval.old_eval_root;
2309 cx->cx_type = CXt_SUB;
2310 cx->blk_sub.hasargs = 0;
2312 cx->blk_sub.cv = cv;
2313 cx->blk_sub.olddepth = CvDEPTH(cv);
2315 if (CvDEPTH(cv) < 2)
2316 (void)SvREFCNT_inc(cv);
2317 else { /* save temporaries on recursion? */
2318 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2319 sub_crush_depth(cv);
2320 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2321 AV *newpad = newAV();
2322 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2323 I32 ix = AvFILLp((AV*)svp[1]);
2324 I32 names_fill = AvFILLp((AV*)svp[0]);
2325 svp = AvARRAY(svp[0]);
2326 for ( ;ix > 0; ix--) {
2327 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2328 char *name = SvPVX(svp[ix]);
2329 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2332 /* outer lexical or anon code */
2333 av_store(newpad, ix,
2334 SvREFCNT_inc(oldpad[ix]) );
2336 else { /* our own lexical */
2338 av_store(newpad, ix, sv = (SV*)newAV());
2339 else if (*name == '%')
2340 av_store(newpad, ix, sv = (SV*)newHV());
2342 av_store(newpad, ix, sv = NEWSV(0,0));
2346 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2347 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2350 av_store(newpad, ix, sv = NEWSV(0,0));
2354 if (cx->blk_sub.hasargs) {
2357 av_store(newpad, 0, (SV*)av);
2358 AvFLAGS(av) = AVf_REIFY;
2360 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2361 AvFILLp(padlist) = CvDEPTH(cv);
2362 svp = AvARRAY(padlist);
2366 if (!cx->blk_sub.hasargs) {
2367 AV* av = (AV*)PL_curpad[0];
2369 items = AvFILLp(av) + 1;
2371 /* Mark is at the end of the stack. */
2373 Copy(AvARRAY(av), SP + 1, items, SV*);
2378 #endif /* USE_THREADS */
2379 SAVEVPTR(PL_curpad);
2380 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2382 if (cx->blk_sub.hasargs)
2383 #endif /* USE_THREADS */
2385 AV* av = (AV*)PL_curpad[0];
2389 cx->blk_sub.savearray = GvAV(PL_defgv);
2390 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2391 #endif /* USE_THREADS */
2392 cx->blk_sub.oldcurpad = PL_curpad;
2393 cx->blk_sub.argarray = av;
2396 if (items >= AvMAX(av) + 1) {
2398 if (AvARRAY(av) != ary) {
2399 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2400 SvPVX(av) = (char*)ary;
2402 if (items >= AvMAX(av) + 1) {
2403 AvMAX(av) = items - 1;
2404 Renew(ary,items+1,SV*);
2406 SvPVX(av) = (char*)ary;
2409 Copy(mark,AvARRAY(av),items,SV*);
2410 AvFILLp(av) = items - 1;
2411 assert(!AvREAL(av));
2418 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2420 * We do not care about using sv to call CV;
2421 * it's for informational purposes only.
2423 SV *sv = GvSV(PL_DBsub);
2426 if (PERLDB_SUB_NN) {
2427 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2430 gv_efullname3(sv, CvGV(cv), Nullch);
2433 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2434 PUSHMARK( PL_stack_sp );
2435 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2439 RETURNOP(CvSTART(cv));
2443 label = SvPV(sv,n_a);
2444 if (!(do_dump || *label))
2445 DIE(aTHX_ must_have_label);
2448 else if (PL_op->op_flags & OPf_SPECIAL) {
2450 DIE(aTHX_ must_have_label);
2453 label = cPVOP->op_pv;
2455 if (label && *label) {
2460 PL_lastgotoprobe = 0;
2462 for (ix = cxstack_ix; ix >= 0; ix--) {
2464 switch (CxTYPE(cx)) {
2466 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2469 gotoprobe = cx->blk_oldcop->op_sibling;
2475 gotoprobe = cx->blk_oldcop->op_sibling;
2477 gotoprobe = PL_main_root;
2480 if (CvDEPTH(cx->blk_sub.cv)) {
2481 gotoprobe = CvROOT(cx->blk_sub.cv);
2487 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2490 DIE(aTHX_ "panic: goto");
2491 gotoprobe = PL_main_root;
2495 retop = dofindlabel(gotoprobe, label,
2496 enterops, enterops + GOTO_DEPTH);
2500 PL_lastgotoprobe = gotoprobe;
2503 DIE(aTHX_ "Can't find label %s", label);
2505 /* pop unwanted frames */
2507 if (ix < cxstack_ix) {
2514 oldsave = PL_scopestack[PL_scopestack_ix];
2515 LEAVE_SCOPE(oldsave);
2518 /* push wanted frames */
2520 if (*enterops && enterops[1]) {
2522 for (ix = 1; enterops[ix]; ix++) {
2523 PL_op = enterops[ix];
2524 /* Eventually we may want to stack the needed arguments
2525 * for each op. For now, we punt on the hard ones. */
2526 if (PL_op->op_type == OP_ENTERITER)
2527 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2528 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2536 if (!retop) retop = PL_main_start;
2538 PL_restartop = retop;
2539 PL_do_undump = TRUE;
2543 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2544 PL_do_undump = FALSE;
2560 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2564 PL_exit_flags |= PERL_EXIT_EXPECTED;
2566 PUSHs(&PL_sv_undef);
2574 NV value = SvNVx(GvSV(cCOP->cop_gv));
2575 register I32 match = I_32(value);
2578 if (((NV)match) > value)
2579 --match; /* was fractional--truncate other way */
2581 match -= cCOP->uop.scop.scop_offset;
2584 else if (match > cCOP->uop.scop.scop_max)
2585 match = cCOP->uop.scop.scop_max;
2586 PL_op = cCOP->uop.scop.scop_next[match];
2596 PL_op = PL_op->op_next; /* can't assume anything */
2599 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2600 match -= cCOP->uop.scop.scop_offset;
2603 else if (match > cCOP->uop.scop.scop_max)
2604 match = cCOP->uop.scop.scop_max;
2605 PL_op = cCOP->uop.scop.scop_next[match];
2614 S_save_lines(pTHX_ AV *array, SV *sv)
2616 register char *s = SvPVX(sv);
2617 register char *send = SvPVX(sv) + SvCUR(sv);
2619 register I32 line = 1;
2621 while (s && s < send) {
2622 SV *tmpstr = NEWSV(85,0);
2624 sv_upgrade(tmpstr, SVt_PVMG);
2625 t = strchr(s, '\n');
2631 sv_setpvn(tmpstr, s, t - s);
2632 av_store(array, line++, tmpstr);
2637 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2639 S_docatch_body(pTHX_ va_list args)
2641 return docatch_body();
2646 S_docatch_body(pTHX)
2653 S_docatch(pTHX_ OP *o)
2658 volatile PERL_SI *cursi = PL_curstackinfo;
2662 assert(CATCH_GET == TRUE);
2665 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2667 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2673 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2679 if (PL_restartop && cursi == PL_curstackinfo) {
2680 PL_op = PL_restartop;
2697 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2698 /* sv Text to convert to OP tree. */
2699 /* startop op_free() this to undo. */
2700 /* code Short string id of the caller. */
2702 dSP; /* Make POPBLOCK work. */
2705 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2709 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2710 char *tmpbuf = tbuf;
2716 /* switch to eval mode */
2718 if (PL_curcop == &PL_compiling) {
2719 SAVECOPSTASH_FREE(&PL_compiling);
2720 CopSTASH_set(&PL_compiling, PL_curstash);
2722 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2723 SV *sv = sv_newmortal();
2724 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2725 code, (unsigned long)++PL_evalseq,
2726 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2730 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2731 SAVECOPFILE_FREE(&PL_compiling);
2732 CopFILE_set(&PL_compiling, tmpbuf+2);
2733 SAVECOPLINE(&PL_compiling);
2734 CopLINE_set(&PL_compiling, 1);
2735 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2736 deleting the eval's FILEGV from the stash before gv_check() runs
2737 (i.e. before run-time proper). To work around the coredump that
2738 ensues, we always turn GvMULTI_on for any globals that were
2739 introduced within evals. See force_ident(). GSAR 96-10-12 */
2740 safestr = savepv(tmpbuf);
2741 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2743 #ifdef OP_IN_REGISTER
2751 PL_op->op_type = OP_ENTEREVAL;
2752 PL_op->op_flags = 0; /* Avoid uninit warning. */
2753 PUSHBLOCK(cx, CXt_EVAL, SP);
2754 PUSHEVAL(cx, 0, Nullgv);
2755 rop = doeval(G_SCALAR, startop);
2756 POPBLOCK(cx,PL_curpm);
2759 (*startop)->op_type = OP_NULL;
2760 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2762 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2764 if (PL_curcop == &PL_compiling)
2765 PL_compiling.op_private = PL_hints;
2766 #ifdef OP_IN_REGISTER
2772 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2774 S_doeval(pTHX_ int gimme, OP** startop)
2782 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2783 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2788 /* set up a scratch pad */
2791 SAVEVPTR(PL_curpad);
2792 SAVESPTR(PL_comppad);
2793 SAVESPTR(PL_comppad_name);
2794 SAVEI32(PL_comppad_name_fill);
2795 SAVEI32(PL_min_intro_pending);
2796 SAVEI32(PL_max_intro_pending);
2799 for (i = cxstack_ix - 1; i >= 0; i--) {
2800 PERL_CONTEXT *cx = &cxstack[i];
2801 if (CxTYPE(cx) == CXt_EVAL)
2803 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2804 caller = cx->blk_sub.cv;
2809 SAVESPTR(PL_compcv);
2810 PL_compcv = (CV*)NEWSV(1104,0);
2811 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2812 CvEVAL_on(PL_compcv);
2814 CvOWNER(PL_compcv) = 0;
2815 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2816 MUTEX_INIT(CvMUTEXP(PL_compcv));
2817 #endif /* USE_THREADS */
2819 PL_comppad = newAV();
2820 av_push(PL_comppad, Nullsv);
2821 PL_curpad = AvARRAY(PL_comppad);
2822 PL_comppad_name = newAV();
2823 PL_comppad_name_fill = 0;
2824 PL_min_intro_pending = 0;
2827 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2828 PL_curpad[0] = (SV*)newAV();
2829 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2830 #endif /* USE_THREADS */
2832 comppadlist = newAV();
2833 AvREAL_off(comppadlist);
2834 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2835 av_store(comppadlist, 1, (SV*)PL_comppad);
2836 CvPADLIST(PL_compcv) = comppadlist;
2839 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2841 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2844 SAVEFREESV(PL_compcv);
2846 /* make sure we compile in the right package */
2848 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2849 SAVESPTR(PL_curstash);
2850 PL_curstash = CopSTASH(PL_curcop);
2852 SAVESPTR(PL_beginav);
2853 PL_beginav = newAV();
2854 SAVEFREESV(PL_beginav);
2855 SAVEI32(PL_error_count);
2857 /* try to compile it */
2859 PL_eval_root = Nullop;
2861 PL_curcop = &PL_compiling;
2862 PL_curcop->cop_arybase = 0;
2863 SvREFCNT_dec(PL_rs);
2864 PL_rs = newSVpvn("\n", 1);
2865 if (saveop && saveop->op_flags & OPf_SPECIAL)
2866 PL_in_eval |= EVAL_KEEPERR;
2869 if (yyparse() || PL_error_count || !PL_eval_root) {
2873 I32 optype = 0; /* Might be reset by POPEVAL. */
2878 op_free(PL_eval_root);
2879 PL_eval_root = Nullop;
2881 SP = PL_stack_base + POPMARK; /* pop original mark */
2883 POPBLOCK(cx,PL_curpm);
2889 if (optype == OP_REQUIRE) {
2890 char* msg = SvPVx(ERRSV, n_a);
2891 DIE(aTHX_ "%sCompilation failed in require",
2892 *msg ? msg : "Unknown error\n");
2895 char* msg = SvPVx(ERRSV, n_a);
2897 POPBLOCK(cx,PL_curpm);
2899 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2900 (*msg ? msg : "Unknown error\n"));
2902 SvREFCNT_dec(PL_rs);
2903 PL_rs = SvREFCNT_inc(PL_nrs);
2905 MUTEX_LOCK(&PL_eval_mutex);
2907 COND_SIGNAL(&PL_eval_cond);
2908 MUTEX_UNLOCK(&PL_eval_mutex);
2909 #endif /* USE_THREADS */
2912 SvREFCNT_dec(PL_rs);
2913 PL_rs = SvREFCNT_inc(PL_nrs);
2914 CopLINE_set(&PL_compiling, 0);
2916 *startop = PL_eval_root;
2917 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2918 CvOUTSIDE(PL_compcv) = Nullcv;
2920 SAVEFREEOP(PL_eval_root);
2922 scalarvoid(PL_eval_root);
2923 else if (gimme & G_ARRAY)
2926 scalar(PL_eval_root);
2928 DEBUG_x(dump_eval());
2930 /* Register with debugger: */
2931 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2932 CV *cv = get_cv("DB::postponed", FALSE);
2936 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2938 call_sv((SV*)cv, G_DISCARD);
2942 /* compiled okay, so do it */
2944 CvDEPTH(PL_compcv) = 1;
2945 SP = PL_stack_base + POPMARK; /* pop original mark */
2946 PL_op = saveop; /* The caller may need it. */
2947 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2949 MUTEX_LOCK(&PL_eval_mutex);
2951 COND_SIGNAL(&PL_eval_cond);
2952 MUTEX_UNLOCK(&PL_eval_mutex);
2953 #endif /* USE_THREADS */
2955 RETURNOP(PL_eval_start);
2959 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2961 STRLEN namelen = strlen(name);
2964 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2965 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2966 char *pmc = SvPV_nolen(pmcsv);
2969 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2970 fp = PerlIO_open(name, mode);
2973 if (PerlLIO_stat(name, &pmstat) < 0 ||
2974 pmstat.st_mtime < pmcstat.st_mtime)
2976 fp = PerlIO_open(pmc, mode);
2979 fp = PerlIO_open(name, mode);
2982 SvREFCNT_dec(pmcsv);
2985 fp = PerlIO_open(name, mode);
2993 register PERL_CONTEXT *cx;
2998 SV *namesv = Nullsv;
3000 I32 gimme = G_SCALAR;
3001 PerlIO *tryrsfp = 0;
3003 int filter_has_file = 0;
3004 GV *filter_child_proc = 0;
3005 SV *filter_state = 0;
3010 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3011 UV rev = 0, ver = 0, sver = 0;
3013 U8 *s = (U8*)SvPVX(sv);
3014 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3016 rev = utf8_to_uv(s, end - s, &len, 0);
3019 ver = utf8_to_uv(s, end - s, &len, 0);
3022 sver = utf8_to_uv(s, end - s, &len, 0);
3025 if (PERL_REVISION < rev
3026 || (PERL_REVISION == rev
3027 && (PERL_VERSION < ver
3028 || (PERL_VERSION == ver
3029 && PERL_SUBVERSION < sver))))
3031 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3032 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3033 PERL_VERSION, PERL_SUBVERSION);
3037 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3038 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3039 + ((NV)PERL_SUBVERSION/(NV)1000000)
3040 + 0.00000099 < SvNV(sv))
3044 NV nver = (nrev - rev) * 1000;
3045 UV ver = (UV)(nver + 0.0009);
3046 NV nsver = (nver - ver) * 1000;
3047 UV sver = (UV)(nsver + 0.0009);
3049 /* help out with the "use 5.6" confusion */
3050 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3051 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3052 "this is only v%d.%d.%d, stopped"
3053 " (did you mean v%"UVuf".%"UVuf".0?)",
3054 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3055 PERL_SUBVERSION, rev, ver/100);
3058 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3059 "this is only v%d.%d.%d, stopped",
3060 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3067 name = SvPV(sv, len);
3068 if (!(name && len > 0 && *name))
3069 DIE(aTHX_ "Null filename used");
3070 TAINT_PROPER("require");
3071 if (PL_op->op_type == OP_REQUIRE &&
3072 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3073 *svp != &PL_sv_undef)
3076 /* prepare to compile file */
3078 if (PERL_FILE_IS_ABSOLUTE(name)
3079 || (*name == '.' && (name[1] == '/' ||
3080 (name[1] == '.' && name[2] == '/'))))
3083 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3084 #ifdef MACOS_TRADITIONAL
3085 /* We consider paths of the form :a:b ambiguous and interpret them first
3086 as global then as local
3088 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3097 AV *ar = GvAVn(PL_incgv);
3101 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3104 namesv = NEWSV(806, 0);
3105 for (i = 0; i <= AvFILL(ar); i++) {
3106 SV *dirsv = *av_fetch(ar, i, TRUE);
3112 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3113 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3116 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3117 PTR2UV(SvANY(loader)), name);
3118 tryname = SvPVX(namesv);
3129 count = call_sv(loader, G_ARRAY);
3139 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3143 if (SvTYPE(arg) == SVt_PVGV) {
3144 IO *io = GvIO((GV *)arg);
3149 tryrsfp = IoIFP(io);
3150 if (IoTYPE(io) == IoTYPE_PIPE) {
3151 /* reading from a child process doesn't
3152 nest -- when returning from reading
3153 the inner module, the outer one is
3154 unreadable (closed?) I've tried to
3155 save the gv to manage the lifespan of
3156 the pipe, but this didn't help. XXX */
3157 filter_child_proc = (GV *)arg;
3158 (void)SvREFCNT_inc(filter_child_proc);
3161 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3162 PerlIO_close(IoOFP(io));
3174 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3176 (void)SvREFCNT_inc(filter_sub);
3179 filter_state = SP[i];
3180 (void)SvREFCNT_inc(filter_state);
3184 tryrsfp = PerlIO_open("/dev/null",
3198 filter_has_file = 0;
3199 if (filter_child_proc) {
3200 SvREFCNT_dec(filter_child_proc);
3201 filter_child_proc = 0;
3204 SvREFCNT_dec(filter_state);
3208 SvREFCNT_dec(filter_sub);
3213 char *dir = SvPVx(dirsv, n_a);
3214 #ifdef MACOS_TRADITIONAL
3216 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3220 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3222 sv_setpv(namesv, unixdir);
3223 sv_catpv(namesv, unixname);
3225 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3228 TAINT_PROPER("require");
3229 tryname = SvPVX(namesv);
3230 #ifdef MACOS_TRADITIONAL
3232 /* Convert slashes in the name part, but not the directory part, to colons */
3234 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3238 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3240 if (tryname[0] == '.' && tryname[1] == '/')
3248 SAVECOPFILE_FREE(&PL_compiling);
3249 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3250 SvREFCNT_dec(namesv);
3252 if (PL_op->op_type == OP_REQUIRE) {
3253 char *msgstr = name;
3254 if (namesv) { /* did we lookup @INC? */
3255 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3256 SV *dirmsgsv = NEWSV(0, 0);
3257 AV *ar = GvAVn(PL_incgv);
3259 sv_catpvn(msg, " in @INC", 8);
3260 if (instr(SvPVX(msg), ".h "))
3261 sv_catpv(msg, " (change .h to .ph maybe?)");
3262 if (instr(SvPVX(msg), ".ph "))
3263 sv_catpv(msg, " (did you run h2ph?)");
3264 sv_catpv(msg, " (@INC contains:");
3265 for (i = 0; i <= AvFILL(ar); i++) {
3266 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3267 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3268 sv_catsv(msg, dirmsgsv);
3270 sv_catpvn(msg, ")", 1);
3271 SvREFCNT_dec(dirmsgsv);
3272 msgstr = SvPV_nolen(msg);
3274 DIE(aTHX_ "Can't locate %s", msgstr);
3280 SETERRNO(0, SS$_NORMAL);
3282 /* Assume success here to prevent recursive requirement. */
3283 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3284 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3288 lex_start(sv_2mortal(newSVpvn("",0)));
3289 SAVEGENERICSV(PL_rsfp_filters);
3290 PL_rsfp_filters = Nullav;
3295 SAVESPTR(PL_compiling.cop_warnings);
3296 if (PL_dowarn & G_WARN_ALL_ON)
3297 PL_compiling.cop_warnings = pWARN_ALL ;
3298 else if (PL_dowarn & G_WARN_ALL_OFF)
3299 PL_compiling.cop_warnings = pWARN_NONE ;
3301 PL_compiling.cop_warnings = pWARN_STD ;
3303 if (filter_sub || filter_child_proc) {
3304 SV *datasv = filter_add(run_user_filter, Nullsv);
3305 IoLINES(datasv) = filter_has_file;
3306 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3307 IoTOP_GV(datasv) = (GV *)filter_state;
3308 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3311 /* switch to eval mode */
3312 push_return(PL_op->op_next);
3313 PUSHBLOCK(cx, CXt_EVAL, SP);
3314 PUSHEVAL(cx, name, Nullgv);
3316 SAVECOPLINE(&PL_compiling);
3317 CopLINE_set(&PL_compiling, 0);
3321 MUTEX_LOCK(&PL_eval_mutex);
3322 if (PL_eval_owner && PL_eval_owner != thr)
3323 while (PL_eval_owner)
3324 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3325 PL_eval_owner = thr;
3326 MUTEX_UNLOCK(&PL_eval_mutex);
3327 #endif /* USE_THREADS */
3328 return DOCATCH(doeval(G_SCALAR, NULL));
3333 return pp_require();
3339 register PERL_CONTEXT *cx;
3341 I32 gimme = GIMME_V, was = PL_sub_generation;
3342 char tbuf[TYPE_DIGITS(long) + 12];
3343 char *tmpbuf = tbuf;
3348 if (!SvPV(sv,len) || !len)
3350 TAINT_PROPER("eval");
3356 /* switch to eval mode */
3358 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3359 SV *sv = sv_newmortal();
3360 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3361 (unsigned long)++PL_evalseq,
3362 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3366 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3367 SAVECOPFILE_FREE(&PL_compiling);
3368 CopFILE_set(&PL_compiling, tmpbuf+2);
3369 SAVECOPLINE(&PL_compiling);
3370 CopLINE_set(&PL_compiling, 1);
3371 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3372 deleting the eval's FILEGV from the stash before gv_check() runs
3373 (i.e. before run-time proper). To work around the coredump that
3374 ensues, we always turn GvMULTI_on for any globals that were
3375 introduced within evals. See force_ident(). GSAR 96-10-12 */
3376 safestr = savepv(tmpbuf);
3377 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3379 PL_hints = PL_op->op_targ;
3380 SAVESPTR(PL_compiling.cop_warnings);
3381 if (specialWARN(PL_curcop->cop_warnings))
3382 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3384 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3385 SAVEFREESV(PL_compiling.cop_warnings);
3388 push_return(PL_op->op_next);
3389 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3390 PUSHEVAL(cx, 0, Nullgv);
3392 /* prepare to compile string */
3394 if (PERLDB_LINE && PL_curstash != PL_debstash)
3395 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3398 MUTEX_LOCK(&PL_eval_mutex);
3399 if (PL_eval_owner && PL_eval_owner != thr)
3400 while (PL_eval_owner)
3401 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3402 PL_eval_owner = thr;
3403 MUTEX_UNLOCK(&PL_eval_mutex);
3404 #endif /* USE_THREADS */
3405 ret = doeval(gimme, NULL);
3406 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3407 && ret != PL_op->op_next) { /* Successive compilation. */
3408 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3410 return DOCATCH(ret);
3420 register PERL_CONTEXT *cx;
3422 U8 save_flags = PL_op -> op_flags;
3427 retop = pop_return();
3430 if (gimme == G_VOID)
3432 else if (gimme == G_SCALAR) {
3435 if (SvFLAGS(TOPs) & SVs_TEMP)
3438 *MARK = sv_mortalcopy(TOPs);
3442 *MARK = &PL_sv_undef;
3447 /* in case LEAVE wipes old return values */
3448 for (mark = newsp + 1; mark <= SP; mark++) {
3449 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3450 *mark = sv_mortalcopy(*mark);
3451 TAINT_NOT; /* Each item is independent */
3455 PL_curpm = newpm; /* Don't pop $1 et al till now */
3457 if (AvFILLp(PL_comppad_name) >= 0)
3461 assert(CvDEPTH(PL_compcv) == 1);
3463 CvDEPTH(PL_compcv) = 0;
3466 if (optype == OP_REQUIRE &&
3467 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3469 /* Unassume the success we assumed earlier. */
3470 SV *nsv = cx->blk_eval.old_namesv;
3471 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3472 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3473 /* die_where() did LEAVE, or we won't be here */
3477 if (!(save_flags & OPf_SPECIAL))
3487 register PERL_CONTEXT *cx;
3488 I32 gimme = GIMME_V;
3493 push_return(cLOGOP->op_other->op_next);
3494 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3496 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3498 PL_in_eval = EVAL_INEVAL;
3501 return DOCATCH(PL_op->op_next);
3511 register PERL_CONTEXT *cx;
3519 if (gimme == G_VOID)
3521 else if (gimme == G_SCALAR) {
3524 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3527 *MARK = sv_mortalcopy(TOPs);
3531 *MARK = &PL_sv_undef;
3536 /* in case LEAVE wipes old return values */
3537 for (mark = newsp + 1; mark <= SP; mark++) {
3538 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3539 *mark = sv_mortalcopy(*mark);
3540 TAINT_NOT; /* Each item is independent */
3544 PL_curpm = newpm; /* Don't pop $1 et al till now */
3552 S_doparseform(pTHX_ SV *sv)
3555 register char *s = SvPV_force(sv, len);
3556 register char *send = s + len;
3557 register char *base;
3558 register I32 skipspaces = 0;
3561 bool postspace = FALSE;
3569 Perl_croak(aTHX_ "Null picture in formline");
3571 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3576 *fpc++ = FF_LINEMARK;
3577 noblank = repeat = FALSE;
3595 case ' ': case '\t':
3606 *fpc++ = FF_LITERAL;
3614 *fpc++ = skipspaces;
3618 *fpc++ = FF_NEWLINE;
3622 arg = fpc - linepc + 1;
3629 *fpc++ = FF_LINEMARK;
3630 noblank = repeat = FALSE;
3639 ischop = s[-1] == '^';
3645 arg = (s - base) - 1;
3647 *fpc++ = FF_LITERAL;
3656 *fpc++ = FF_LINEGLOB;
3658 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3659 arg = ischop ? 512 : 0;
3669 arg |= 256 + (s - f);
3671 *fpc++ = s - base; /* fieldsize for FETCH */
3672 *fpc++ = FF_DECIMAL;
3675 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3676 arg = ischop ? 512 : 0;
3678 s++; /* skip the '0' first */
3687 arg |= 256 + (s - f);
3689 *fpc++ = s - base; /* fieldsize for FETCH */
3690 *fpc++ = FF_0DECIMAL;
3695 bool ismore = FALSE;
3698 while (*++s == '>') ;
3699 prespace = FF_SPACE;
3701 else if (*s == '|') {
3702 while (*++s == '|') ;
3703 prespace = FF_HALFSPACE;
3708 while (*++s == '<') ;
3711 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3715 *fpc++ = s - base; /* fieldsize for FETCH */
3717 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3735 { /* need to jump to the next word */
3737 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3738 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3739 s = SvPVX(sv) + SvCUR(sv) + z;
3741 Copy(fops, s, arg, U16);
3743 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3748 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3750 * The original code was written in conjunction with BSD Computer Software
3751 * Research Group at University of California, Berkeley.
3753 * See also: "Optimistic Merge Sort" (SODA '92)
3755 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3757 * The code can be distributed under the same terms as Perl itself.
3762 #include <sys/types.h>
3767 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3768 #define Safefree(VAR) free(VAR)
3769 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3770 #endif /* TESTHARNESS */
3772 typedef char * aptr; /* pointer for arithmetic on sizes */
3773 typedef SV * gptr; /* pointers in our lists */
3775 /* Binary merge internal sort, with a few special mods
3776 ** for the special perl environment it now finds itself in.
3778 ** Things that were once options have been hotwired
3779 ** to values suitable for this use. In particular, we'll always
3780 ** initialize looking for natural runs, we'll always produce stable
3781 ** output, and we'll always do Peter McIlroy's binary merge.
3784 /* Pointer types for arithmetic and storage and convenience casts */
3786 #define APTR(P) ((aptr)(P))
3787 #define GPTP(P) ((gptr *)(P))
3788 #define GPPP(P) ((gptr **)(P))
3791 /* byte offset from pointer P to (larger) pointer Q */
3792 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3794 #define PSIZE sizeof(gptr)
3796 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3799 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3800 #define PNBYTE(N) ((N) << (PSHIFT))
3801 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3803 /* Leave optimization to compiler */
3804 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3805 #define PNBYTE(N) ((N) * (PSIZE))
3806 #define PINDEX(P, N) (GPTP(P) + (N))
3809 /* Pointer into other corresponding to pointer into this */
3810 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3812 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3815 /* Runs are identified by a pointer in the auxilliary list.
3816 ** The pointer is at the start of the list,
3817 ** and it points to the start of the next list.
3818 ** NEXT is used as an lvalue, too.
3821 #define NEXT(P) (*GPPP(P))
3824 /* PTHRESH is the minimum number of pairs with the same sense to justify
3825 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3826 ** not just elements, so PTHRESH == 8 means a run of 16.
3831 /* RTHRESH is the number of elements in a run that must compare low
3832 ** to the low element from the opposing run before we justify
3833 ** doing a binary rampup instead of single stepping.
3834 ** In random input, N in a row low should only happen with
3835 ** probability 2^(1-N), so we can risk that we are dealing
3836 ** with orderly input without paying much when we aren't.
3843 ** Overview of algorithm and variables.
3844 ** The array of elements at list1 will be organized into runs of length 2,
3845 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3846 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3848 ** Unless otherwise specified, pair pointers address the first of two elements.
3850 ** b and b+1 are a pair that compare with sense ``sense''.
3851 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3853 ** p2 parallels b in the list2 array, where runs are defined by
3856 ** t represents the ``top'' of the adjacent pairs that might extend
3857 ** the run beginning at b. Usually, t addresses a pair
3858 ** that compares with opposite sense from (b,b+1).
3859 ** However, it may also address a singleton element at the end of list1,
3860 ** or it may be equal to ``last'', the first element beyond list1.
3862 ** r addresses the Nth pair following b. If this would be beyond t,
3863 ** we back it off to t. Only when r is less than t do we consider the
3864 ** run long enough to consider checking.
3866 ** q addresses a pair such that the pairs at b through q already form a run.
3867 ** Often, q will equal b, indicating we only are sure of the pair itself.
3868 ** However, a search on the previous cycle may have revealed a longer run,
3869 ** so q may be greater than b.
3871 ** p is used to work back from a candidate r, trying to reach q,
3872 ** which would mean b through r would be a run. If we discover such a run,
3873 ** we start q at r and try to push it further towards t.
3874 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3875 ** In any event, after the check (if any), we have two main cases.
3877 ** 1) Short run. b <= q < p <= r <= t.
3878 ** b through q is a run (perhaps trivial)
3879 ** q through p are uninteresting pairs
3880 ** p through r is a run
3882 ** 2) Long run. b < r <= q < t.
3883 ** b through q is a run (of length >= 2 * PTHRESH)
3885 ** Note that degenerate cases are not only possible, but likely.
3886 ** For example, if the pair following b compares with opposite sense,
3887 ** then b == q < p == r == t.
3892 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3895 register gptr *b, *p, *q, *t, *p2;
3896 register gptr c, *last, *r;
3900 last = PINDEX(b, nmemb);
3901 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3902 for (p2 = list2; b < last; ) {
3903 /* We just started, or just reversed sense.
3904 ** Set t at end of pairs with the prevailing sense.
3906 for (p = b+2, t = p; ++p < last; t = ++p) {
3907 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3910 /* Having laid out the playing field, look for long runs */
3912 p = r = b + (2 * PTHRESH);
3913 if (r >= t) p = r = t; /* too short to care about */
3915 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3918 /* b through r is a (long) run.
3919 ** Extend it as far as possible.
3922 while (((p += 2) < t) &&
3923 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3924 r = p = q + 2; /* no simple pairs, no after-run */
3927 if (q > b) { /* run of greater than 2 at b */
3930 /* pick up singleton, if possible */
3932 ((t + 1) == last) &&
3933 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3934 savep = r = p = q = last;
3935 p2 = NEXT(p2) = p2 + (p - b);
3936 if (sense) while (b < --p) {
3943 while (q < p) { /* simple pairs */
3944 p2 = NEXT(p2) = p2 + 2;
3951 if (((b = p) == t) && ((t+1) == last)) {
3963 /* Overview of bmerge variables:
3965 ** list1 and list2 address the main and auxiliary arrays.
3966 ** They swap identities after each merge pass.
3967 ** Base points to the original list1, so we can tell if
3968 ** the pointers ended up where they belonged (or must be copied).
3970 ** When we are merging two lists, f1 and f2 are the next elements
3971 ** on the respective lists. l1 and l2 mark the end of the lists.
3972 ** tp2 is the current location in the merged list.
3974 ** p1 records where f1 started.
3975 ** After the merge, a new descriptor is built there.
3977 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3978 ** It is used to identify and delimit the runs.
3980 ** In the heat of determining where q, the greater of the f1/f2 elements,
3981 ** belongs in the other list, b, t and p, represent bottom, top and probe
3982 ** locations, respectively, in the other list.
3983 ** They make convenient temporary pointers in other places.
3987 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
3991 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
3992 gptr *aux, *list2, *p2, *last;
3996 if (nmemb <= 1) return; /* sorted trivially */
3997 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
3999 dynprep(aTHX_ list1, list2, nmemb, cmp);
4000 last = PINDEX(list2, nmemb);
4001 while (NEXT(list2) != last) {
4002 /* More than one run remains. Do some merging to reduce runs. */
4004 for (tp2 = p2 = list2; p2 != last;) {
4005 /* The new first run begins where the old second list ended.
4006 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4010 f2 = l1 = POTHER(t, list2, list1);
4011 if (t != last) t = NEXT(t);
4012 l2 = POTHER(t, list2, list1);
4014 while (f1 < l1 && f2 < l2) {
4015 /* If head 1 is larger than head 2, find ALL the elements
4016 ** in list 2 strictly less than head1, write them all,
4017 ** then head 1. Then compare the new heads, and repeat,
4018 ** until one or both lists are exhausted.
4020 ** In all comparisons (after establishing
4021 ** which head to merge) the item to merge
4022 ** (at pointer q) is the first operand of
4023 ** the comparison. When we want to know
4024 ** if ``q is strictly less than the other'',
4026 ** cmp(q, other) < 0
4027 ** because stability demands that we treat equality
4028 ** as high when q comes from l2, and as low when
4029 ** q was from l1. So we ask the question by doing
4030 ** cmp(q, other) <= sense
4031 ** and make sense == 0 when equality should look low,
4032 ** and -1 when equality should look high.
4036 if (cmp(aTHX_ *f1, *f2) <= 0) {
4037 q = f2; b = f1; t = l1;
4040 q = f1; b = f2; t = l2;
4047 ** Leave t at something strictly
4048 ** greater than q (or at the end of the list),
4049 ** and b at something strictly less than q.
4051 for (i = 1, run = 0 ;;) {
4052 if ((p = PINDEX(b, i)) >= t) {
4054 if (((p = PINDEX(t, -1)) > b) &&
4055 (cmp(aTHX_ *q, *p) <= sense))
4059 } else if (cmp(aTHX_ *q, *p) <= sense) {
4063 if (++run >= RTHRESH) i += i;
4067 /* q is known to follow b and must be inserted before t.
4068 ** Increment b, so the range of possibilities is [b,t).
4069 ** Round binary split down, to favor early appearance.
4070 ** Adjust b and t until q belongs just before t.
4075 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4076 if (cmp(aTHX_ *q, *p) <= sense) {
4082 /* Copy all the strictly low elements */
4085 FROMTOUPTO(f2, tp2, t);
4088 FROMTOUPTO(f1, tp2, t);
4094 /* Run out remaining list */
4096 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4097 } else FROMTOUPTO(f1, tp2, l1);
4098 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4103 last = PINDEX(list2, nmemb);
4105 if (base == list2) {
4106 last = PINDEX(list1, nmemb);
4107 FROMTOUPTO(list1, list2, last);
4122 sortcv(pTHXo_ SV *a, SV *b)
4125 I32 oldsaveix = PL_savestack_ix;
4126 I32 oldscopeix = PL_scopestack_ix;
4128 GvSV(PL_firstgv) = a;
4129 GvSV(PL_secondgv) = b;
4130 PL_stack_sp = PL_stack_base;
4133 if (PL_stack_sp != PL_stack_base + 1)
4134 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4135 if (!SvNIOKp(*PL_stack_sp))
4136 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4137 result = SvIV(*PL_stack_sp);
4138 while (PL_scopestack_ix > oldscopeix) {
4141 leave_scope(oldsaveix);
4146 sortcv_stacked(pTHXo_ SV *a, SV *b)
4149 I32 oldsaveix = PL_savestack_ix;
4150 I32 oldscopeix = PL_scopestack_ix;
4155 av = (AV*)PL_curpad[0];
4157 av = GvAV(PL_defgv);
4160 if (AvMAX(av) < 1) {
4161 SV** ary = AvALLOC(av);
4162 if (AvARRAY(av) != ary) {
4163 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4164 SvPVX(av) = (char*)ary;
4166 if (AvMAX(av) < 1) {
4169 SvPVX(av) = (char*)ary;
4176 PL_stack_sp = PL_stack_base;
4179 if (PL_stack_sp != PL_stack_base + 1)
4180 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4181 if (!SvNIOKp(*PL_stack_sp))
4182 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4183 result = SvIV(*PL_stack_sp);
4184 while (PL_scopestack_ix > oldscopeix) {
4187 leave_scope(oldsaveix);
4192 sortcv_xsub(pTHXo_ SV *a, SV *b)
4195 I32 oldsaveix = PL_savestack_ix;
4196 I32 oldscopeix = PL_scopestack_ix;
4198 CV *cv=(CV*)PL_sortcop;
4206 (void)(*CvXSUB(cv))(aTHXo_ cv);
4207 if (PL_stack_sp != PL_stack_base + 1)
4208 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4209 if (!SvNIOKp(*PL_stack_sp))
4210 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4211 result = SvIV(*PL_stack_sp);
4212 while (PL_scopestack_ix > oldscopeix) {
4215 leave_scope(oldsaveix);
4221 sv_ncmp(pTHXo_ SV *a, SV *b)
4225 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4229 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4233 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4235 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4237 if (PL_amagic_generation) { \
4238 if (SvAMAGIC(left)||SvAMAGIC(right))\
4239 *svp = amagic_call(left, \
4247 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4250 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4255 I32 i = SvIVX(tmpsv);
4265 return sv_ncmp(aTHXo_ a, b);
4269 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4272 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4277 I32 i = SvIVX(tmpsv);
4287 return sv_i_ncmp(aTHXo_ a, b);
4291 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4294 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4299 I32 i = SvIVX(tmpsv);
4309 return sv_cmp(str1, str2);
4313 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4316 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4321 I32 i = SvIVX(tmpsv);
4331 return sv_cmp_locale(str1, str2);
4335 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4337 SV *datasv = FILTER_DATA(idx);
4338 int filter_has_file = IoLINES(datasv);
4339 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4340 SV *filter_state = (SV *)IoTOP_GV(datasv);
4341 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4344 /* I was having segfault trouble under Linux 2.2.5 after a
4345 parse error occured. (Had to hack around it with a test
4346 for PL_error_count == 0.) Solaris doesn't segfault --
4347 not sure where the trouble is yet. XXX */
4349 if (filter_has_file) {
4350 len = FILTER_READ(idx+1, buf_sv, maxlen);
4353 if (filter_sub && len >= 0) {
4364 PUSHs(sv_2mortal(newSViv(maxlen)));
4366 PUSHs(filter_state);
4369 count = call_sv(filter_sub, G_SCALAR);
4385 IoLINES(datasv) = 0;
4386 if (filter_child_proc) {
4387 SvREFCNT_dec(filter_child_proc);
4388 IoFMT_GV(datasv) = Nullgv;
4391 SvREFCNT_dec(filter_state);
4392 IoTOP_GV(datasv) = Nullgv;
4395 SvREFCNT_dec(filter_sub);
4396 IoBOTTOM_GV(datasv) = Nullgv;
4398 filter_del(run_user_filter);
4407 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4409 return sv_cmp_locale(str1, str2);
4413 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4415 return sv_cmp(str1, str2);
4418 #endif /* PERL_OBJECT */