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 { /* Update the pos() information. */
215 SV *sv = cx->sb_targ;
218 if (SvTYPE(sv) < SVt_PVMG)
219 SvUPGRADE(sv, SVt_PVMG);
220 if (!(mg = mg_find(sv, 'g'))) {
221 sv_magic(sv, Nullsv, 'g', Nullch, 0);
222 mg = mg_find(sv, 'g');
229 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
230 rxres_save(&cx->sb_rxres, rx);
231 RETURNOP(pm->op_pmreplstart);
235 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
240 if (!p || p[1] < rx->nparens) {
241 i = 6 + rx->nparens * 2;
249 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
250 RX_MATCH_COPIED_off(rx);
254 *p++ = PTR2UV(rx->subbeg);
255 *p++ = (UV)rx->sublen;
256 for (i = 0; i <= rx->nparens; ++i) {
257 *p++ = (UV)rx->startp[i];
258 *p++ = (UV)rx->endp[i];
263 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
268 if (RX_MATCH_COPIED(rx))
269 Safefree(rx->subbeg);
270 RX_MATCH_COPIED_set(rx, *p);
275 rx->subbeg = INT2PTR(char*,*p++);
276 rx->sublen = (I32)(*p++);
277 for (i = 0; i <= rx->nparens; ++i) {
278 rx->startp[i] = (I32)(*p++);
279 rx->endp[i] = (I32)(*p++);
284 Perl_rxres_free(pTHX_ void **rsp)
289 Safefree(INT2PTR(char*,*p));
297 djSP; dMARK; dORIGMARK;
298 register SV *tmpForm = *++MARK;
310 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
316 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
317 bool item_is_utf = FALSE;
319 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
320 if (SvREADONLY(tmpForm)) {
321 SvREADONLY_off(tmpForm);
322 doparseform(tmpForm);
323 SvREADONLY_on(tmpForm);
326 doparseform(tmpForm);
329 SvPV_force(PL_formtarget, len);
330 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
332 f = SvPV(tmpForm, len);
333 /* need to jump to the next word */
334 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
343 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
344 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
345 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
346 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
347 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
349 case FF_CHECKNL: name = "CHECKNL"; break;
350 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
351 case FF_SPACE: name = "SPACE"; break;
352 case FF_HALFSPACE: name = "HALFSPACE"; break;
353 case FF_ITEM: name = "ITEM"; break;
354 case FF_CHOP: name = "CHOP"; break;
355 case FF_LINEGLOB: name = "LINEGLOB"; break;
356 case FF_NEWLINE: name = "NEWLINE"; break;
357 case FF_MORE: name = "MORE"; break;
358 case FF_LINEMARK: name = "LINEMARK"; break;
359 case FF_END: name = "END"; break;
360 case FF_0DECIMAL: name = "0DECIMAL"; break;
363 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
365 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
393 if (ckWARN(WARN_SYNTAX))
394 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
399 item = s = SvPV(sv, len);
402 itemsize = sv_len_utf8(sv);
403 if (itemsize != len) {
405 if (itemsize > fieldsize) {
406 itemsize = fieldsize;
407 itembytes = itemsize;
408 sv_pos_u2b(sv, &itembytes, 0);
412 send = chophere = s + itembytes;
422 sv_pos_b2u(sv, &itemsize);
427 if (itemsize > fieldsize)
428 itemsize = fieldsize;
429 send = chophere = s + itemsize;
441 item = s = SvPV(sv, len);
444 itemsize = sv_len_utf8(sv);
445 if (itemsize != len) {
447 if (itemsize <= fieldsize) {
448 send = chophere = s + itemsize;
459 itemsize = fieldsize;
460 itembytes = itemsize;
461 sv_pos_u2b(sv, &itembytes, 0);
462 send = chophere = s + itembytes;
463 while (s < send || (s == send && isSPACE(*s))) {
473 if (strchr(PL_chopset, *s))
478 itemsize = chophere - item;
479 sv_pos_b2u(sv, &itemsize);
486 if (itemsize <= fieldsize) {
487 send = chophere = s + itemsize;
498 itemsize = fieldsize;
499 send = chophere = s + itemsize;
500 while (s < send || (s == send && isSPACE(*s))) {
510 if (strchr(PL_chopset, *s))
515 itemsize = chophere - item;
520 arg = fieldsize - itemsize;
529 arg = fieldsize - itemsize;
544 switch (UTF8SKIP(s)) {
555 if ( !((*t++ = *s++) & ~31) )
563 int ch = *t++ = *s++;
566 if ( !((*t++ = *s++) & ~31) )
575 while (*s && isSPACE(*s))
582 item = s = SvPV(sv, len);
584 item_is_utf = FALSE; /* XXX is this correct? */
596 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
597 sv_catpvn(PL_formtarget, item, itemsize);
598 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
599 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
604 /* If the field is marked with ^ and the value is undefined,
607 if ((arg & 512) && !SvOK(sv)) {
615 /* Formats aren't yet marked for locales, so assume "yes". */
617 STORE_NUMERIC_STANDARD_SET_LOCAL();
618 #if defined(USE_LONG_DOUBLE)
620 sprintf(t, "%#*.*" PERL_PRIfldbl,
621 (int) fieldsize, (int) arg & 255, value);
623 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
628 (int) fieldsize, (int) arg & 255, value);
631 (int) fieldsize, value);
634 RESTORE_NUMERIC_STANDARD();
640 /* If the field is marked with ^ and the value is undefined,
643 if ((arg & 512) && !SvOK(sv)) {
651 /* Formats aren't yet marked for locales, so assume "yes". */
653 STORE_NUMERIC_STANDARD_SET_LOCAL();
654 #if defined(USE_LONG_DOUBLE)
656 sprintf(t, "%#0*.*" PERL_PRIfldbl,
657 (int) fieldsize, (int) arg & 255, value);
658 /* is this legal? I don't have long doubles */
660 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
664 sprintf(t, "%#0*.*f",
665 (int) fieldsize, (int) arg & 255, value);
668 (int) fieldsize, value);
671 RESTORE_NUMERIC_STANDARD();
678 while (t-- > linemark && *t == ' ') ;
686 if (arg) { /* repeat until fields exhausted? */
688 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
689 lines += FmLINES(PL_formtarget);
692 if (strnEQ(linemark, linemark - arg, arg))
693 DIE(aTHX_ "Runaway format");
695 FmLINES(PL_formtarget) = lines;
697 RETURNOP(cLISTOP->op_first);
710 while (*s && isSPACE(*s) && s < send)
714 arg = fieldsize - itemsize;
721 if (strnEQ(s," ",3)) {
722 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
733 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
734 FmLINES(PL_formtarget) += lines;
746 if (PL_stack_base + *PL_markstack_ptr == SP) {
748 if (GIMME_V == G_SCALAR)
749 XPUSHs(sv_2mortal(newSViv(0)));
750 RETURNOP(PL_op->op_next->op_next);
752 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
753 pp_pushmark(); /* push dst */
754 pp_pushmark(); /* push src */
755 ENTER; /* enter outer scope */
758 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
760 ENTER; /* enter inner scope */
763 src = PL_stack_base[*PL_markstack_ptr];
768 if (PL_op->op_type == OP_MAPSTART)
769 pp_pushmark(); /* push top */
770 return ((LOGOP*)PL_op->op_next)->op_other;
775 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
781 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
787 /* first, move source pointer to the next item in the source list */
788 ++PL_markstack_ptr[-1];
790 /* if there are new items, push them into the destination list */
792 /* might need to make room back there first */
793 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
794 /* XXX this implementation is very pessimal because the stack
795 * is repeatedly extended for every set of items. Is possible
796 * to do this without any stack extension or copying at all
797 * by maintaining a separate list over which the map iterates
798 * (like foreach does). --gsar */
800 /* everything in the stack after the destination list moves
801 * towards the end the stack by the amount of room needed */
802 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
804 /* items to shift up (accounting for the moved source pointer) */
805 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
807 /* This optimization is by Ben Tilly and it does
808 * things differently from what Sarathy (gsar)
809 * is describing. The downside of this optimization is
810 * that leaves "holes" (uninitialized and hopefully unused areas)
811 * to the Perl stack, but on the other hand this
812 * shouldn't be a problem. If Sarathy's idea gets
813 * implemented, this optimization should become
814 * irrelevant. --jhi */
816 shift = count; /* Avoid shifting too often --Ben Tilly */
821 PL_markstack_ptr[-1] += shift;
822 *PL_markstack_ptr += shift;
826 /* copy the new items down to the destination list */
827 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
829 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
831 LEAVE; /* exit inner scope */
834 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
837 (void)POPMARK; /* pop top */
838 LEAVE; /* exit outer scope */
839 (void)POPMARK; /* pop src */
840 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
841 (void)POPMARK; /* pop dst */
842 SP = PL_stack_base + POPMARK; /* pop original mark */
843 if (gimme == G_SCALAR) {
847 else if (gimme == G_ARRAY)
854 ENTER; /* enter inner scope */
857 /* set $_ to the new source item */
858 src = PL_stack_base[PL_markstack_ptr[-1]];
862 RETURNOP(cLOGOP->op_other);
868 djSP; dMARK; dORIGMARK;
870 SV **myorigmark = ORIGMARK;
876 OP* nextop = PL_op->op_next;
878 bool hasargs = FALSE;
881 if (gimme != G_ARRAY) {
887 SAVEVPTR(PL_sortcop);
888 if (PL_op->op_flags & OPf_STACKED) {
889 if (PL_op->op_flags & OPf_SPECIAL) {
890 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
891 kid = kUNOP->op_first; /* pass rv2gv */
892 kid = kUNOP->op_first; /* pass leave */
893 PL_sortcop = kid->op_next;
894 stash = CopSTASH(PL_curcop);
897 cv = sv_2cv(*++MARK, &stash, &gv, 0);
898 if (cv && SvPOK(cv)) {
900 char *proto = SvPV((SV*)cv, n_a);
901 if (proto && strEQ(proto, "$$")) {
905 if (!(cv && CvROOT(cv))) {
906 if (cv && CvXSUB(cv)) {
910 SV *tmpstr = sv_newmortal();
911 gv_efullname3(tmpstr, gv, Nullch);
912 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
916 DIE(aTHX_ "Undefined subroutine in sort");
921 PL_sortcop = (OP*)cv;
923 PL_sortcop = CvSTART(cv);
924 SAVEVPTR(CvROOT(cv)->op_ppaddr);
925 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
928 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
934 stash = CopSTASH(PL_curcop);
938 while (MARK < SP) { /* This may or may not shift down one here. */
940 if ((*up = *++MARK)) { /* Weed out nulls. */
942 if (!PL_sortcop && !SvPOK(*up)) {
947 (void)sv_2pv(*up, &n_a);
952 max = --up - myorigmark;
957 bool oldcatch = CATCH_GET;
963 PUSHSTACKi(PERLSI_SORT);
964 if (!hasargs && !is_xsub) {
965 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
966 SAVESPTR(PL_firstgv);
967 SAVESPTR(PL_secondgv);
968 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
969 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
970 PL_sortstash = stash;
973 sv_lock((SV *)PL_firstgv);
974 sv_lock((SV *)PL_secondgv);
976 SAVESPTR(GvSV(PL_firstgv));
977 SAVESPTR(GvSV(PL_secondgv));
980 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
981 if (!(PL_op->op_flags & OPf_SPECIAL)) {
982 cx->cx_type = CXt_SUB;
983 cx->blk_gimme = G_SCALAR;
986 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
988 PL_sortcxix = cxstack_ix;
990 if (hasargs && !is_xsub) {
991 /* This is mostly copied from pp_entersub */
992 AV *av = (AV*)PL_curpad[0];
995 cx->blk_sub.savearray = GvAV(PL_defgv);
996 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
997 #endif /* USE_THREADS */
998 cx->blk_sub.oldcurpad = PL_curpad;
999 cx->blk_sub.argarray = av;
1001 qsortsv((myorigmark+1), max,
1002 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1004 POPBLOCK(cx,PL_curpm);
1005 PL_stack_sp = newsp;
1007 CATCH_SET(oldcatch);
1012 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1013 qsortsv(ORIGMARK+1, max,
1014 (PL_op->op_private & OPpSORT_NUMERIC)
1015 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1016 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1017 : ( overloading ? amagic_ncmp : sv_ncmp))
1018 : ( (PL_op->op_private & OPpLOCALE)
1021 : sv_cmp_locale_static)
1022 : ( overloading ? amagic_cmp : sv_cmp_static)));
1023 if (PL_op->op_private & OPpSORT_REVERSE) {
1024 SV **p = ORIGMARK+1;
1025 SV **q = ORIGMARK+max;
1035 PL_stack_sp = ORIGMARK + max;
1043 if (GIMME == G_ARRAY)
1045 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1046 return cLOGOP->op_other;
1055 if (GIMME == G_ARRAY) {
1056 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1060 SV *targ = PAD_SV(PL_op->op_targ);
1063 if (PL_op->op_private & OPpFLIP_LINENUM) {
1065 flip = PL_last_in_gv
1066 && (gp_io = GvIOp(PL_last_in_gv))
1067 && SvIV(sv) == (IV)IoLINES(gp_io);
1072 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1073 if (PL_op->op_flags & OPf_SPECIAL) {
1081 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1094 if (GIMME == G_ARRAY) {
1100 if (SvGMAGICAL(left))
1102 if (SvGMAGICAL(right))
1105 if (SvNIOKp(left) || !SvPOKp(left) ||
1106 SvNIOKp(right) || !SvPOKp(right) ||
1107 (looks_like_number(left) && *SvPVX(left) != '0' &&
1108 looks_like_number(right) && *SvPVX(right) != '0'))
1110 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1111 DIE(aTHX_ "Range iterator outside integer range");
1122 sv = sv_2mortal(newSViv(i++));
1127 SV *final = sv_mortalcopy(right);
1129 char *tmps = SvPV(final, len);
1131 sv = sv_mortalcopy(left);
1133 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1135 if (strEQ(SvPVX(sv),tmps))
1137 sv = sv_2mortal(newSVsv(sv));
1144 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1146 if ((PL_op->op_private & OPpFLIP_LINENUM)
1147 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1149 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1150 sv_catpv(targ, "E0");
1161 S_dopoptolabel(pTHX_ char *label)
1165 register PERL_CONTEXT *cx;
1167 for (i = cxstack_ix; i >= 0; i--) {
1169 switch (CxTYPE(cx)) {
1171 if (ckWARN(WARN_EXITING))
1172 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1173 PL_op_name[PL_op->op_type]);
1176 if (ckWARN(WARN_EXITING))
1177 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1178 PL_op_name[PL_op->op_type]);
1181 if (ckWARN(WARN_EXITING))
1182 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1183 PL_op_name[PL_op->op_type]);
1186 if (ckWARN(WARN_EXITING))
1187 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1188 PL_op_name[PL_op->op_type]);
1191 if (ckWARN(WARN_EXITING))
1192 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1193 PL_op_name[PL_op->op_type]);
1196 if (!cx->blk_loop.label ||
1197 strNE(label, cx->blk_loop.label) ) {
1198 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1199 (long)i, cx->blk_loop.label));
1202 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1210 Perl_dowantarray(pTHX)
1212 I32 gimme = block_gimme();
1213 return (gimme == G_VOID) ? G_SCALAR : gimme;
1217 Perl_block_gimme(pTHX)
1222 cxix = dopoptosub(cxstack_ix);
1226 switch (cxstack[cxix].blk_gimme) {
1234 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1241 S_dopoptosub(pTHX_ I32 startingblock)
1244 return dopoptosub_at(cxstack, startingblock);
1248 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1252 register PERL_CONTEXT *cx;
1253 for (i = startingblock; i >= 0; i--) {
1255 switch (CxTYPE(cx)) {
1261 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1269 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)
1292 register PERL_CONTEXT *cx;
1293 for (i = startingblock; i >= 0; i--) {
1295 switch (CxTYPE(cx)) {
1297 if (ckWARN(WARN_EXITING))
1298 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1299 PL_op_name[PL_op->op_type]);
1302 if (ckWARN(WARN_EXITING))
1303 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1304 PL_op_name[PL_op->op_type]);
1307 if (ckWARN(WARN_EXITING))
1308 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1309 PL_op_name[PL_op->op_type]);
1312 if (ckWARN(WARN_EXITING))
1313 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1314 PL_op_name[PL_op->op_type]);
1317 if (ckWARN(WARN_EXITING))
1318 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1319 PL_op_name[PL_op->op_type]);
1322 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1330 Perl_dounwind(pTHX_ I32 cxix)
1333 register PERL_CONTEXT *cx;
1336 while (cxstack_ix > cxix) {
1338 cx = &cxstack[cxstack_ix];
1339 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1340 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1341 /* Note: we don't need to restore the base context info till the end. */
1342 switch (CxTYPE(cx)) {
1345 continue; /* not break */
1367 * Closures mentioned at top level of eval cannot be referenced
1368 * again, and their presence indirectly causes a memory leak.
1369 * (Note that the fact that compcv and friends are still set here
1370 * is, AFAIK, an accident.) --Chip
1372 * XXX need to get comppad et al from eval's cv rather than
1373 * relying on the incidental global values.
1376 S_free_closures(pTHX)
1379 SV **svp = AvARRAY(PL_comppad_name);
1381 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1383 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1385 svp[ix] = &PL_sv_undef;
1389 SvREFCNT_dec(CvOUTSIDE(sv));
1390 CvOUTSIDE(sv) = Nullcv;
1403 Perl_qerror(pTHX_ SV *err)
1406 sv_catsv(ERRSV, err);
1408 sv_catsv(PL_errors, err);
1410 Perl_warn(aTHX_ "%"SVf, err);
1415 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1420 register PERL_CONTEXT *cx;
1425 if (PL_in_eval & EVAL_KEEPERR) {
1426 static char prefix[] = "\t(in cleanup) ";
1431 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1434 if (*e != *message || strNE(e,message))
1438 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1439 sv_catpvn(err, prefix, sizeof(prefix)-1);
1440 sv_catpvn(err, message, msglen);
1441 if (ckWARN(WARN_MISC)) {
1442 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1443 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1448 sv_setpvn(ERRSV, message, msglen);
1451 message = SvPVx(ERRSV, msglen);
1453 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1454 && PL_curstackinfo->si_prev)
1463 if (cxix < cxstack_ix)
1466 POPBLOCK(cx,PL_curpm);
1467 if (CxTYPE(cx) != CXt_EVAL) {
1468 PerlIO_write(Perl_error_log, "panic: die ", 11);
1469 PerlIO_write(Perl_error_log, message, msglen);
1474 if (gimme == G_SCALAR)
1475 *++newsp = &PL_sv_undef;
1476 PL_stack_sp = newsp;
1480 /* LEAVE could clobber PL_curcop (see save_re_context())
1481 * XXX it might be better to find a way to avoid messing with
1482 * PL_curcop in save_re_context() instead, but this is a more
1483 * minimal fix --GSAR */
1484 PL_curcop = cx->blk_oldcop;
1486 if (optype == OP_REQUIRE) {
1487 char* msg = SvPVx(ERRSV, n_a);
1488 DIE(aTHX_ "%sCompilation failed in require",
1489 *msg ? msg : "Unknown error\n");
1491 return pop_return();
1495 message = SvPVx(ERRSV, msglen);
1498 /* SFIO can really mess with your errno */
1501 PerlIO *serr = Perl_error_log;
1503 PerlIO_write(serr, message, msglen);
1504 (void)PerlIO_flush(serr);
1517 if (SvTRUE(left) != SvTRUE(right))
1529 RETURNOP(cLOGOP->op_other);
1538 RETURNOP(cLOGOP->op_other);
1544 register I32 cxix = dopoptosub(cxstack_ix);
1545 register PERL_CONTEXT *cx;
1546 register PERL_CONTEXT *ccstack = cxstack;
1547 PERL_SI *top_si = PL_curstackinfo;
1558 /* we may be in a higher stacklevel, so dig down deeper */
1559 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1560 top_si = top_si->si_prev;
1561 ccstack = top_si->si_cxstack;
1562 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1565 if (GIMME != G_ARRAY)
1569 if (PL_DBsub && cxix >= 0 &&
1570 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1574 cxix = dopoptosub_at(ccstack, cxix - 1);
1577 cx = &ccstack[cxix];
1578 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1579 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1580 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1581 field below is defined for any cx. */
1582 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1583 cx = &ccstack[dbcxix];
1586 stashname = CopSTASHPV(cx->blk_oldcop);
1587 if (GIMME != G_ARRAY) {
1589 PUSHs(&PL_sv_undef);
1592 sv_setpv(TARG, stashname);
1599 PUSHs(&PL_sv_undef);
1601 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1602 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1603 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1606 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1607 /* So is ccstack[dbcxix]. */
1609 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1610 PUSHs(sv_2mortal(sv));
1611 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1614 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1615 PUSHs(sv_2mortal(newSViv(0)));
1617 gimme = (I32)cx->blk_gimme;
1618 if (gimme == G_VOID)
1619 PUSHs(&PL_sv_undef);
1621 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1622 if (CxTYPE(cx) == CXt_EVAL) {
1624 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1625 PUSHs(cx->blk_eval.cur_text);
1629 else if (cx->blk_eval.old_namesv) {
1630 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1633 /* eval BLOCK (try blocks have old_namesv == 0) */
1635 PUSHs(&PL_sv_undef);
1636 PUSHs(&PL_sv_undef);
1640 PUSHs(&PL_sv_undef);
1641 PUSHs(&PL_sv_undef);
1643 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1644 && CopSTASH_eq(PL_curcop, PL_debstash))
1646 AV *ary = cx->blk_sub.argarray;
1647 int off = AvARRAY(ary) - AvALLOC(ary);
1651 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1654 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1657 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1658 av_extend(PL_dbargs, AvFILLp(ary) + off);
1659 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1660 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1662 /* XXX only hints propagated via op_private are currently
1663 * visible (others are not easily accessible, since they
1664 * use the global PL_hints) */
1665 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1666 HINT_PRIVATE_MASK)));
1669 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1671 if (old_warnings == pWARN_NONE ||
1672 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1673 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1674 else if (old_warnings == pWARN_ALL ||
1675 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1676 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1678 mask = newSVsv(old_warnings);
1679 PUSHs(sv_2mortal(mask));
1694 sv_reset(tmps, CopSTASH(PL_curcop));
1706 PL_curcop = (COP*)PL_op;
1707 TAINT_NOT; /* Each statement is presumed innocent */
1708 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1711 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1715 register PERL_CONTEXT *cx;
1716 I32 gimme = G_ARRAY;
1723 DIE(aTHX_ "No DB::DB routine defined");
1725 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1737 push_return(PL_op->op_next);
1738 PUSHBLOCK(cx, CXt_SUB, SP);
1741 (void)SvREFCNT_inc(cv);
1742 SAVEVPTR(PL_curpad);
1743 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1744 RETURNOP(CvSTART(cv));
1758 register PERL_CONTEXT *cx;
1759 I32 gimme = GIMME_V;
1761 U32 cxtype = CXt_LOOP;
1770 if (PL_op->op_flags & OPf_SPECIAL) {
1772 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1773 SAVEGENERICSV(*svp);
1777 #endif /* USE_THREADS */
1778 if (PL_op->op_targ) {
1779 #ifndef USE_ITHREADS
1780 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1783 SAVEPADSV(PL_op->op_targ);
1784 iterdata = (void*)PL_op->op_targ;
1785 cxtype |= CXp_PADVAR;
1790 svp = &GvSV(gv); /* symbol table variable */
1791 SAVEGENERICSV(*svp);
1794 iterdata = (void*)gv;
1800 PUSHBLOCK(cx, cxtype, SP);
1802 PUSHLOOP(cx, iterdata, MARK);
1804 PUSHLOOP(cx, svp, MARK);
1806 if (PL_op->op_flags & OPf_STACKED) {
1807 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1808 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1810 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1811 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1812 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1813 looks_like_number((SV*)cx->blk_loop.iterary) &&
1814 *SvPVX(cx->blk_loop.iterary) != '0'))
1816 if (SvNV(sv) < IV_MIN ||
1817 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1818 DIE(aTHX_ "Range iterator outside integer range");
1819 cx->blk_loop.iterix = SvIV(sv);
1820 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1823 cx->blk_loop.iterlval = newSVsv(sv);
1827 cx->blk_loop.iterary = PL_curstack;
1828 AvFILLp(PL_curstack) = SP - PL_stack_base;
1829 cx->blk_loop.iterix = MARK - PL_stack_base;
1838 register PERL_CONTEXT *cx;
1839 I32 gimme = GIMME_V;
1845 PUSHBLOCK(cx, CXt_LOOP, SP);
1846 PUSHLOOP(cx, 0, SP);
1854 register PERL_CONTEXT *cx;
1862 newsp = PL_stack_base + cx->blk_loop.resetsp;
1865 if (gimme == G_VOID)
1867 else if (gimme == G_SCALAR) {
1869 *++newsp = sv_mortalcopy(*SP);
1871 *++newsp = &PL_sv_undef;
1875 *++newsp = sv_mortalcopy(*++mark);
1876 TAINT_NOT; /* Each item is independent */
1882 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1883 PL_curpm = newpm; /* ... and pop $1 et al */
1895 register PERL_CONTEXT *cx;
1896 bool popsub2 = FALSE;
1897 bool clear_errsv = FALSE;
1904 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1905 if (cxstack_ix == PL_sortcxix
1906 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1908 if (cxstack_ix > PL_sortcxix)
1909 dounwind(PL_sortcxix);
1910 AvARRAY(PL_curstack)[1] = *SP;
1911 PL_stack_sp = PL_stack_base + 1;
1916 cxix = dopoptosub(cxstack_ix);
1918 DIE(aTHX_ "Can't return outside a subroutine");
1919 if (cxix < cxstack_ix)
1923 switch (CxTYPE(cx)) {
1928 if (!(PL_in_eval & EVAL_KEEPERR))
1933 if (AvFILLp(PL_comppad_name) >= 0)
1936 if (optype == OP_REQUIRE &&
1937 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1939 /* Unassume the success we assumed earlier. */
1940 SV *nsv = cx->blk_eval.old_namesv;
1941 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1942 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1949 DIE(aTHX_ "panic: return");
1953 if (gimme == G_SCALAR) {
1956 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1958 *++newsp = SvREFCNT_inc(*SP);
1963 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1965 *++newsp = sv_mortalcopy(sv);
1970 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1973 *++newsp = sv_mortalcopy(*SP);
1976 *++newsp = &PL_sv_undef;
1978 else if (gimme == G_ARRAY) {
1979 while (++MARK <= SP) {
1980 *++newsp = (popsub2 && SvTEMP(*MARK))
1981 ? *MARK : sv_mortalcopy(*MARK);
1982 TAINT_NOT; /* Each item is independent */
1985 PL_stack_sp = newsp;
1987 /* Stack values are safe: */
1989 POPSUB(cx,sv); /* release CV and @_ ... */
1993 PL_curpm = newpm; /* ... and pop $1 et al */
1999 return pop_return();
2006 register PERL_CONTEXT *cx;
2016 if (PL_op->op_flags & OPf_SPECIAL) {
2017 cxix = dopoptoloop(cxstack_ix);
2019 DIE(aTHX_ "Can't \"last\" outside a loop block");
2022 cxix = dopoptolabel(cPVOP->op_pv);
2024 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2026 if (cxix < cxstack_ix)
2031 switch (CxTYPE(cx)) {
2034 newsp = PL_stack_base + cx->blk_loop.resetsp;
2035 nextop = cx->blk_loop.last_op->op_next;
2039 nextop = pop_return();
2043 nextop = pop_return();
2047 nextop = pop_return();
2050 DIE(aTHX_ "panic: last");
2054 if (gimme == G_SCALAR) {
2056 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2057 ? *SP : sv_mortalcopy(*SP);
2059 *++newsp = &PL_sv_undef;
2061 else if (gimme == G_ARRAY) {
2062 while (++MARK <= SP) {
2063 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2064 ? *MARK : sv_mortalcopy(*MARK);
2065 TAINT_NOT; /* Each item is independent */
2071 /* Stack values are safe: */
2074 POPLOOP(cx); /* release loop vars ... */
2078 POPSUB(cx,sv); /* release CV and @_ ... */
2081 PL_curpm = newpm; /* ... and pop $1 et al */
2091 register PERL_CONTEXT *cx;
2094 if (PL_op->op_flags & OPf_SPECIAL) {
2095 cxix = dopoptoloop(cxstack_ix);
2097 DIE(aTHX_ "Can't \"next\" outside a loop block");
2100 cxix = dopoptolabel(cPVOP->op_pv);
2102 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2104 if (cxix < cxstack_ix)
2107 /* clear off anything above the scope we're re-entering, but
2108 * save the rest until after a possible continue block */
2109 inner = PL_scopestack_ix;
2111 if (PL_scopestack_ix < inner)
2112 leave_scope(PL_scopestack[PL_scopestack_ix]);
2113 return cx->blk_loop.next_op;
2119 register PERL_CONTEXT *cx;
2122 if (PL_op->op_flags & OPf_SPECIAL) {
2123 cxix = dopoptoloop(cxstack_ix);
2125 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2128 cxix = dopoptolabel(cPVOP->op_pv);
2130 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2132 if (cxix < cxstack_ix)
2136 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2137 LEAVE_SCOPE(oldsave);
2138 return cx->blk_loop.redo_op;
2142 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2146 static char too_deep[] = "Target of goto is too deeply nested";
2149 Perl_croak(aTHX_ too_deep);
2150 if (o->op_type == OP_LEAVE ||
2151 o->op_type == OP_SCOPE ||
2152 o->op_type == OP_LEAVELOOP ||
2153 o->op_type == OP_LEAVETRY)
2155 *ops++ = cUNOPo->op_first;
2157 Perl_croak(aTHX_ too_deep);
2160 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)
2675 volatile PERL_SI *cursi = PL_curstackinfo;
2679 assert(CATCH_GET == TRUE);
2682 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2684 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2690 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2696 if (PL_restartop && cursi == PL_curstackinfo) {
2697 PL_op = PL_restartop;
2714 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2715 /* sv Text to convert to OP tree. */
2716 /* startop op_free() this to undo. */
2717 /* code Short string id of the caller. */
2719 dSP; /* Make POPBLOCK work. */
2722 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2726 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2727 char *tmpbuf = tbuf;
2733 /* switch to eval mode */
2735 if (PL_curcop == &PL_compiling) {
2736 SAVECOPSTASH_FREE(&PL_compiling);
2737 CopSTASH_set(&PL_compiling, PL_curstash);
2739 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2740 SV *sv = sv_newmortal();
2741 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2742 code, (unsigned long)++PL_evalseq,
2743 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2747 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2748 SAVECOPFILE_FREE(&PL_compiling);
2749 CopFILE_set(&PL_compiling, tmpbuf+2);
2750 SAVECOPLINE(&PL_compiling);
2751 CopLINE_set(&PL_compiling, 1);
2752 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2753 deleting the eval's FILEGV from the stash before gv_check() runs
2754 (i.e. before run-time proper). To work around the coredump that
2755 ensues, we always turn GvMULTI_on for any globals that were
2756 introduced within evals. See force_ident(). GSAR 96-10-12 */
2757 safestr = savepv(tmpbuf);
2758 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2760 #ifdef OP_IN_REGISTER
2768 PL_op->op_type = OP_ENTEREVAL;
2769 PL_op->op_flags = 0; /* Avoid uninit warning. */
2770 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2771 PUSHEVAL(cx, 0, Nullgv);
2772 rop = doeval(G_SCALAR, startop);
2773 POPBLOCK(cx,PL_curpm);
2776 (*startop)->op_type = OP_NULL;
2777 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2779 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2781 if (PL_curcop == &PL_compiling)
2782 PL_compiling.op_private = PL_hints;
2783 #ifdef OP_IN_REGISTER
2789 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2791 S_doeval(pTHX_ int gimme, OP** startop)
2799 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2800 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2805 /* set up a scratch pad */
2808 SAVEVPTR(PL_curpad);
2809 SAVESPTR(PL_comppad);
2810 SAVESPTR(PL_comppad_name);
2811 SAVEI32(PL_comppad_name_fill);
2812 SAVEI32(PL_min_intro_pending);
2813 SAVEI32(PL_max_intro_pending);
2816 for (i = cxstack_ix - 1; i >= 0; i--) {
2817 PERL_CONTEXT *cx = &cxstack[i];
2818 if (CxTYPE(cx) == CXt_EVAL)
2820 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2821 caller = cx->blk_sub.cv;
2826 SAVESPTR(PL_compcv);
2827 PL_compcv = (CV*)NEWSV(1104,0);
2828 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2829 CvEVAL_on(PL_compcv);
2831 CvOWNER(PL_compcv) = 0;
2832 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2833 MUTEX_INIT(CvMUTEXP(PL_compcv));
2834 #endif /* USE_THREADS */
2836 PL_comppad = newAV();
2837 av_push(PL_comppad, Nullsv);
2838 PL_curpad = AvARRAY(PL_comppad);
2839 PL_comppad_name = newAV();
2840 PL_comppad_name_fill = 0;
2841 PL_min_intro_pending = 0;
2844 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2845 PL_curpad[0] = (SV*)newAV();
2846 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2847 #endif /* USE_THREADS */
2849 comppadlist = newAV();
2850 AvREAL_off(comppadlist);
2851 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2852 av_store(comppadlist, 1, (SV*)PL_comppad);
2853 CvPADLIST(PL_compcv) = comppadlist;
2856 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2858 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2861 SAVEFREESV(PL_compcv);
2863 /* make sure we compile in the right package */
2865 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2866 SAVESPTR(PL_curstash);
2867 PL_curstash = CopSTASH(PL_curcop);
2869 SAVESPTR(PL_beginav);
2870 PL_beginav = newAV();
2871 SAVEFREESV(PL_beginav);
2872 SAVEI32(PL_error_count);
2874 /* try to compile it */
2876 PL_eval_root = Nullop;
2878 PL_curcop = &PL_compiling;
2879 PL_curcop->cop_arybase = 0;
2880 SvREFCNT_dec(PL_rs);
2881 PL_rs = newSVpvn("\n", 1);
2882 if (saveop && saveop->op_flags & OPf_SPECIAL)
2883 PL_in_eval |= EVAL_KEEPERR;
2886 if (yyparse() || PL_error_count || !PL_eval_root) {
2890 I32 optype = 0; /* Might be reset by POPEVAL. */
2895 op_free(PL_eval_root);
2896 PL_eval_root = Nullop;
2898 SP = PL_stack_base + POPMARK; /* pop original mark */
2900 POPBLOCK(cx,PL_curpm);
2906 if (optype == OP_REQUIRE) {
2907 char* msg = SvPVx(ERRSV, n_a);
2908 DIE(aTHX_ "%sCompilation failed in require",
2909 *msg ? msg : "Unknown error\n");
2912 char* msg = SvPVx(ERRSV, n_a);
2914 POPBLOCK(cx,PL_curpm);
2916 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2917 (*msg ? msg : "Unknown error\n"));
2919 SvREFCNT_dec(PL_rs);
2920 PL_rs = SvREFCNT_inc(PL_nrs);
2922 MUTEX_LOCK(&PL_eval_mutex);
2924 COND_SIGNAL(&PL_eval_cond);
2925 MUTEX_UNLOCK(&PL_eval_mutex);
2926 #endif /* USE_THREADS */
2929 SvREFCNT_dec(PL_rs);
2930 PL_rs = SvREFCNT_inc(PL_nrs);
2931 CopLINE_set(&PL_compiling, 0);
2933 *startop = PL_eval_root;
2934 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2935 CvOUTSIDE(PL_compcv) = Nullcv;
2937 SAVEFREEOP(PL_eval_root);
2939 scalarvoid(PL_eval_root);
2940 else if (gimme & G_ARRAY)
2943 scalar(PL_eval_root);
2945 DEBUG_x(dump_eval());
2947 /* Register with debugger: */
2948 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2949 CV *cv = get_cv("DB::postponed", FALSE);
2953 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2955 call_sv((SV*)cv, G_DISCARD);
2959 /* compiled okay, so do it */
2961 CvDEPTH(PL_compcv) = 1;
2962 SP = PL_stack_base + POPMARK; /* pop original mark */
2963 PL_op = saveop; /* The caller may need it. */
2964 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2966 MUTEX_LOCK(&PL_eval_mutex);
2968 COND_SIGNAL(&PL_eval_cond);
2969 MUTEX_UNLOCK(&PL_eval_mutex);
2970 #endif /* USE_THREADS */
2972 RETURNOP(PL_eval_start);
2976 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2978 STRLEN namelen = strlen(name);
2981 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2982 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2983 char *pmc = SvPV_nolen(pmcsv);
2986 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2987 fp = PerlIO_open(name, mode);
2990 if (PerlLIO_stat(name, &pmstat) < 0 ||
2991 pmstat.st_mtime < pmcstat.st_mtime)
2993 fp = PerlIO_open(pmc, mode);
2996 fp = PerlIO_open(name, mode);
2999 SvREFCNT_dec(pmcsv);
3002 fp = PerlIO_open(name, mode);
3010 register PERL_CONTEXT *cx;
3015 SV *namesv = Nullsv;
3017 I32 gimme = G_SCALAR;
3018 PerlIO *tryrsfp = 0;
3020 int filter_has_file = 0;
3021 GV *filter_child_proc = 0;
3022 SV *filter_state = 0;
3027 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3028 UV rev = 0, ver = 0, sver = 0;
3030 U8 *s = (U8*)SvPVX(sv);
3031 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3033 rev = utf8_to_uv(s, end - s, &len, 0);
3036 ver = utf8_to_uv(s, end - s, &len, 0);
3039 sver = utf8_to_uv(s, end - s, &len, 0);
3042 if (PERL_REVISION < rev
3043 || (PERL_REVISION == rev
3044 && (PERL_VERSION < ver
3045 || (PERL_VERSION == ver
3046 && PERL_SUBVERSION < sver))))
3048 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3049 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3050 PERL_VERSION, PERL_SUBVERSION);
3054 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3055 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3056 + ((NV)PERL_SUBVERSION/(NV)1000000)
3057 + 0.00000099 < SvNV(sv))
3061 NV nver = (nrev - rev) * 1000;
3062 UV ver = (UV)(nver + 0.0009);
3063 NV nsver = (nver - ver) * 1000;
3064 UV sver = (UV)(nsver + 0.0009);
3066 /* help out with the "use 5.6" confusion */
3067 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3068 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3069 "this is only v%d.%d.%d, stopped"
3070 " (did you mean v%"UVuf".%"UVuf".0?)",
3071 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3072 PERL_SUBVERSION, rev, ver/100);
3075 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3076 "this is only v%d.%d.%d, stopped",
3077 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3084 name = SvPV(sv, len);
3085 if (!(name && len > 0 && *name))
3086 DIE(aTHX_ "Null filename used");
3087 TAINT_PROPER("require");
3088 if (PL_op->op_type == OP_REQUIRE &&
3089 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3090 *svp != &PL_sv_undef)
3093 /* prepare to compile file */
3095 if (PERL_FILE_IS_ABSOLUTE(name)
3096 || (*name == '.' && (name[1] == '/' ||
3097 (name[1] == '.' && name[2] == '/'))))
3100 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3101 #ifdef MACOS_TRADITIONAL
3102 /* We consider paths of the form :a:b ambiguous and interpret them first
3103 as global then as local
3105 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3114 AV *ar = GvAVn(PL_incgv);
3118 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3121 namesv = NEWSV(806, 0);
3122 for (i = 0; i <= AvFILL(ar); i++) {
3123 SV *dirsv = *av_fetch(ar, i, TRUE);
3129 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3130 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3133 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3134 PTR2UV(SvANY(loader)), name);
3135 tryname = SvPVX(namesv);
3146 count = call_sv(loader, G_ARRAY);
3156 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3160 if (SvTYPE(arg) == SVt_PVGV) {
3161 IO *io = GvIO((GV *)arg);
3166 tryrsfp = IoIFP(io);
3167 if (IoTYPE(io) == IoTYPE_PIPE) {
3168 /* reading from a child process doesn't
3169 nest -- when returning from reading
3170 the inner module, the outer one is
3171 unreadable (closed?) I've tried to
3172 save the gv to manage the lifespan of
3173 the pipe, but this didn't help. XXX */
3174 filter_child_proc = (GV *)arg;
3175 (void)SvREFCNT_inc(filter_child_proc);
3178 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3179 PerlIO_close(IoOFP(io));
3191 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3193 (void)SvREFCNT_inc(filter_sub);
3196 filter_state = SP[i];
3197 (void)SvREFCNT_inc(filter_state);
3201 tryrsfp = PerlIO_open("/dev/null",
3215 filter_has_file = 0;
3216 if (filter_child_proc) {
3217 SvREFCNT_dec(filter_child_proc);
3218 filter_child_proc = 0;
3221 SvREFCNT_dec(filter_state);
3225 SvREFCNT_dec(filter_sub);
3230 char *dir = SvPVx(dirsv, n_a);
3231 #ifdef MACOS_TRADITIONAL
3233 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3237 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3239 sv_setpv(namesv, unixdir);
3240 sv_catpv(namesv, unixname);
3242 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3245 TAINT_PROPER("require");
3246 tryname = SvPVX(namesv);
3247 #ifdef MACOS_TRADITIONAL
3249 /* Convert slashes in the name part, but not the directory part, to colons */
3251 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3255 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3257 if (tryname[0] == '.' && tryname[1] == '/')
3265 SAVECOPFILE_FREE(&PL_compiling);
3266 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3267 SvREFCNT_dec(namesv);
3269 if (PL_op->op_type == OP_REQUIRE) {
3270 char *msgstr = name;
3271 if (namesv) { /* did we lookup @INC? */
3272 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3273 SV *dirmsgsv = NEWSV(0, 0);
3274 AV *ar = GvAVn(PL_incgv);
3276 sv_catpvn(msg, " in @INC", 8);
3277 if (instr(SvPVX(msg), ".h "))
3278 sv_catpv(msg, " (change .h to .ph maybe?)");
3279 if (instr(SvPVX(msg), ".ph "))
3280 sv_catpv(msg, " (did you run h2ph?)");
3281 sv_catpv(msg, " (@INC contains:");
3282 for (i = 0; i <= AvFILL(ar); i++) {
3283 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3284 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3285 sv_catsv(msg, dirmsgsv);
3287 sv_catpvn(msg, ")", 1);
3288 SvREFCNT_dec(dirmsgsv);
3289 msgstr = SvPV_nolen(msg);
3291 DIE(aTHX_ "Can't locate %s", msgstr);
3297 SETERRNO(0, SS$_NORMAL);
3299 /* Assume success here to prevent recursive requirement. */
3300 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3301 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3305 lex_start(sv_2mortal(newSVpvn("",0)));
3306 SAVEGENERICSV(PL_rsfp_filters);
3307 PL_rsfp_filters = Nullav;
3312 SAVESPTR(PL_compiling.cop_warnings);
3313 if (PL_dowarn & G_WARN_ALL_ON)
3314 PL_compiling.cop_warnings = pWARN_ALL ;
3315 else if (PL_dowarn & G_WARN_ALL_OFF)
3316 PL_compiling.cop_warnings = pWARN_NONE ;
3318 PL_compiling.cop_warnings = pWARN_STD ;
3319 SAVESPTR(PL_compiling.cop_io);
3320 PL_compiling.cop_io = Nullsv;
3322 if (filter_sub || filter_child_proc) {
3323 SV *datasv = filter_add(run_user_filter, Nullsv);
3324 IoLINES(datasv) = filter_has_file;
3325 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3326 IoTOP_GV(datasv) = (GV *)filter_state;
3327 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3330 /* switch to eval mode */
3331 push_return(PL_op->op_next);
3332 PUSHBLOCK(cx, CXt_EVAL, SP);
3333 PUSHEVAL(cx, name, Nullgv);
3335 SAVECOPLINE(&PL_compiling);
3336 CopLINE_set(&PL_compiling, 0);
3340 MUTEX_LOCK(&PL_eval_mutex);
3341 if (PL_eval_owner && PL_eval_owner != thr)
3342 while (PL_eval_owner)
3343 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3344 PL_eval_owner = thr;
3345 MUTEX_UNLOCK(&PL_eval_mutex);
3346 #endif /* USE_THREADS */
3347 return DOCATCH(doeval(G_SCALAR, NULL));
3352 return pp_require();
3358 register PERL_CONTEXT *cx;
3360 I32 gimme = GIMME_V, was = PL_sub_generation;
3361 char tbuf[TYPE_DIGITS(long) + 12];
3362 char *tmpbuf = tbuf;
3367 if (!SvPV(sv,len) || !len)
3369 TAINT_PROPER("eval");
3375 /* switch to eval mode */
3377 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3378 SV *sv = sv_newmortal();
3379 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3380 (unsigned long)++PL_evalseq,
3381 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3385 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3386 SAVECOPFILE_FREE(&PL_compiling);
3387 CopFILE_set(&PL_compiling, tmpbuf+2);
3388 SAVECOPLINE(&PL_compiling);
3389 CopLINE_set(&PL_compiling, 1);
3390 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3391 deleting the eval's FILEGV from the stash before gv_check() runs
3392 (i.e. before run-time proper). To work around the coredump that
3393 ensues, we always turn GvMULTI_on for any globals that were
3394 introduced within evals. See force_ident(). GSAR 96-10-12 */
3395 safestr = savepv(tmpbuf);
3396 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3398 PL_hints = PL_op->op_targ;
3399 SAVESPTR(PL_compiling.cop_warnings);
3400 if (specialWARN(PL_curcop->cop_warnings))
3401 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3403 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3404 SAVEFREESV(PL_compiling.cop_warnings);
3406 SAVESPTR(PL_compiling.cop_io);
3407 if (specialCopIO(PL_curcop->cop_io))
3408 PL_compiling.cop_io = PL_curcop->cop_io;
3410 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3411 SAVEFREESV(PL_compiling.cop_io);
3414 push_return(PL_op->op_next);
3415 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3416 PUSHEVAL(cx, 0, Nullgv);
3418 /* prepare to compile string */
3420 if (PERLDB_LINE && PL_curstash != PL_debstash)
3421 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3424 MUTEX_LOCK(&PL_eval_mutex);
3425 if (PL_eval_owner && PL_eval_owner != thr)
3426 while (PL_eval_owner)
3427 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3428 PL_eval_owner = thr;
3429 MUTEX_UNLOCK(&PL_eval_mutex);
3430 #endif /* USE_THREADS */
3431 ret = doeval(gimme, NULL);
3432 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3433 && ret != PL_op->op_next) { /* Successive compilation. */
3434 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3436 return DOCATCH(ret);
3446 register PERL_CONTEXT *cx;
3448 U8 save_flags = PL_op -> op_flags;
3453 retop = pop_return();
3456 if (gimme == G_VOID)
3458 else if (gimme == G_SCALAR) {
3461 if (SvFLAGS(TOPs) & SVs_TEMP)
3464 *MARK = sv_mortalcopy(TOPs);
3468 *MARK = &PL_sv_undef;
3473 /* in case LEAVE wipes old return values */
3474 for (mark = newsp + 1; mark <= SP; mark++) {
3475 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3476 *mark = sv_mortalcopy(*mark);
3477 TAINT_NOT; /* Each item is independent */
3481 PL_curpm = newpm; /* Don't pop $1 et al till now */
3483 if (AvFILLp(PL_comppad_name) >= 0)
3487 assert(CvDEPTH(PL_compcv) == 1);
3489 CvDEPTH(PL_compcv) = 0;
3492 if (optype == OP_REQUIRE &&
3493 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3495 /* Unassume the success we assumed earlier. */
3496 SV *nsv = cx->blk_eval.old_namesv;
3497 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3498 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3499 /* die_where() did LEAVE, or we won't be here */
3503 if (!(save_flags & OPf_SPECIAL))
3513 register PERL_CONTEXT *cx;
3514 I32 gimme = GIMME_V;
3519 push_return(cLOGOP->op_other->op_next);
3520 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3522 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3524 PL_in_eval = EVAL_INEVAL;
3527 return DOCATCH(PL_op->op_next);
3537 register PERL_CONTEXT *cx;
3545 if (gimme == G_VOID)
3547 else if (gimme == G_SCALAR) {
3550 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3553 *MARK = sv_mortalcopy(TOPs);
3557 *MARK = &PL_sv_undef;
3562 /* in case LEAVE wipes old return values */
3563 for (mark = newsp + 1; mark <= SP; mark++) {
3564 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3565 *mark = sv_mortalcopy(*mark);
3566 TAINT_NOT; /* Each item is independent */
3570 PL_curpm = newpm; /* Don't pop $1 et al till now */
3578 S_doparseform(pTHX_ SV *sv)
3581 register char *s = SvPV_force(sv, len);
3582 register char *send = s + len;
3583 register char *base;
3584 register I32 skipspaces = 0;
3587 bool postspace = FALSE;
3595 Perl_croak(aTHX_ "Null picture in formline");
3597 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3602 *fpc++ = FF_LINEMARK;
3603 noblank = repeat = FALSE;
3621 case ' ': case '\t':
3632 *fpc++ = FF_LITERAL;
3640 *fpc++ = skipspaces;
3644 *fpc++ = FF_NEWLINE;
3648 arg = fpc - linepc + 1;
3655 *fpc++ = FF_LINEMARK;
3656 noblank = repeat = FALSE;
3665 ischop = s[-1] == '^';
3671 arg = (s - base) - 1;
3673 *fpc++ = FF_LITERAL;
3682 *fpc++ = FF_LINEGLOB;
3684 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3685 arg = ischop ? 512 : 0;
3695 arg |= 256 + (s - f);
3697 *fpc++ = s - base; /* fieldsize for FETCH */
3698 *fpc++ = FF_DECIMAL;
3701 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3702 arg = ischop ? 512 : 0;
3704 s++; /* skip the '0' first */
3713 arg |= 256 + (s - f);
3715 *fpc++ = s - base; /* fieldsize for FETCH */
3716 *fpc++ = FF_0DECIMAL;
3721 bool ismore = FALSE;
3724 while (*++s == '>') ;
3725 prespace = FF_SPACE;
3727 else if (*s == '|') {
3728 while (*++s == '|') ;
3729 prespace = FF_HALFSPACE;
3734 while (*++s == '<') ;
3737 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3741 *fpc++ = s - base; /* fieldsize for FETCH */
3743 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3761 { /* need to jump to the next word */
3763 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3764 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3765 s = SvPVX(sv) + SvCUR(sv) + z;
3767 Copy(fops, s, arg, U16);
3769 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3774 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3776 * The original code was written in conjunction with BSD Computer Software
3777 * Research Group at University of California, Berkeley.
3779 * See also: "Optimistic Merge Sort" (SODA '92)
3781 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3783 * The code can be distributed under the same terms as Perl itself.
3788 #include <sys/types.h>
3793 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3794 #define Safefree(VAR) free(VAR)
3795 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3796 #endif /* TESTHARNESS */
3798 typedef char * aptr; /* pointer for arithmetic on sizes */
3799 typedef SV * gptr; /* pointers in our lists */
3801 /* Binary merge internal sort, with a few special mods
3802 ** for the special perl environment it now finds itself in.
3804 ** Things that were once options have been hotwired
3805 ** to values suitable for this use. In particular, we'll always
3806 ** initialize looking for natural runs, we'll always produce stable
3807 ** output, and we'll always do Peter McIlroy's binary merge.
3810 /* Pointer types for arithmetic and storage and convenience casts */
3812 #define APTR(P) ((aptr)(P))
3813 #define GPTP(P) ((gptr *)(P))
3814 #define GPPP(P) ((gptr **)(P))
3817 /* byte offset from pointer P to (larger) pointer Q */
3818 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3820 #define PSIZE sizeof(gptr)
3822 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3825 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3826 #define PNBYTE(N) ((N) << (PSHIFT))
3827 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3829 /* Leave optimization to compiler */
3830 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3831 #define PNBYTE(N) ((N) * (PSIZE))
3832 #define PINDEX(P, N) (GPTP(P) + (N))
3835 /* Pointer into other corresponding to pointer into this */
3836 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3838 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3841 /* Runs are identified by a pointer in the auxilliary list.
3842 ** The pointer is at the start of the list,
3843 ** and it points to the start of the next list.
3844 ** NEXT is used as an lvalue, too.
3847 #define NEXT(P) (*GPPP(P))
3850 /* PTHRESH is the minimum number of pairs with the same sense to justify
3851 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3852 ** not just elements, so PTHRESH == 8 means a run of 16.
3857 /* RTHRESH is the number of elements in a run that must compare low
3858 ** to the low element from the opposing run before we justify
3859 ** doing a binary rampup instead of single stepping.
3860 ** In random input, N in a row low should only happen with
3861 ** probability 2^(1-N), so we can risk that we are dealing
3862 ** with orderly input without paying much when we aren't.
3869 ** Overview of algorithm and variables.
3870 ** The array of elements at list1 will be organized into runs of length 2,
3871 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3872 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3874 ** Unless otherwise specified, pair pointers address the first of two elements.
3876 ** b and b+1 are a pair that compare with sense ``sense''.
3877 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3879 ** p2 parallels b in the list2 array, where runs are defined by
3882 ** t represents the ``top'' of the adjacent pairs that might extend
3883 ** the run beginning at b. Usually, t addresses a pair
3884 ** that compares with opposite sense from (b,b+1).
3885 ** However, it may also address a singleton element at the end of list1,
3886 ** or it may be equal to ``last'', the first element beyond list1.
3888 ** r addresses the Nth pair following b. If this would be beyond t,
3889 ** we back it off to t. Only when r is less than t do we consider the
3890 ** run long enough to consider checking.
3892 ** q addresses a pair such that the pairs at b through q already form a run.
3893 ** Often, q will equal b, indicating we only are sure of the pair itself.
3894 ** However, a search on the previous cycle may have revealed a longer run,
3895 ** so q may be greater than b.
3897 ** p is used to work back from a candidate r, trying to reach q,
3898 ** which would mean b through r would be a run. If we discover such a run,
3899 ** we start q at r and try to push it further towards t.
3900 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3901 ** In any event, after the check (if any), we have two main cases.
3903 ** 1) Short run. b <= q < p <= r <= t.
3904 ** b through q is a run (perhaps trivial)
3905 ** q through p are uninteresting pairs
3906 ** p through r is a run
3908 ** 2) Long run. b < r <= q < t.
3909 ** b through q is a run (of length >= 2 * PTHRESH)
3911 ** Note that degenerate cases are not only possible, but likely.
3912 ** For example, if the pair following b compares with opposite sense,
3913 ** then b == q < p == r == t.
3918 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3921 register gptr *b, *p, *q, *t, *p2;
3922 register gptr c, *last, *r;
3926 last = PINDEX(b, nmemb);
3927 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3928 for (p2 = list2; b < last; ) {
3929 /* We just started, or just reversed sense.
3930 ** Set t at end of pairs with the prevailing sense.
3932 for (p = b+2, t = p; ++p < last; t = ++p) {
3933 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3936 /* Having laid out the playing field, look for long runs */
3938 p = r = b + (2 * PTHRESH);
3939 if (r >= t) p = r = t; /* too short to care about */
3941 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3944 /* b through r is a (long) run.
3945 ** Extend it as far as possible.
3948 while (((p += 2) < t) &&
3949 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3950 r = p = q + 2; /* no simple pairs, no after-run */
3953 if (q > b) { /* run of greater than 2 at b */
3956 /* pick up singleton, if possible */
3958 ((t + 1) == last) &&
3959 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3960 savep = r = p = q = last;
3961 p2 = NEXT(p2) = p2 + (p - b);
3962 if (sense) while (b < --p) {
3969 while (q < p) { /* simple pairs */
3970 p2 = NEXT(p2) = p2 + 2;
3977 if (((b = p) == t) && ((t+1) == last)) {
3989 /* Overview of bmerge variables:
3991 ** list1 and list2 address the main and auxiliary arrays.
3992 ** They swap identities after each merge pass.
3993 ** Base points to the original list1, so we can tell if
3994 ** the pointers ended up where they belonged (or must be copied).
3996 ** When we are merging two lists, f1 and f2 are the next elements
3997 ** on the respective lists. l1 and l2 mark the end of the lists.
3998 ** tp2 is the current location in the merged list.
4000 ** p1 records where f1 started.
4001 ** After the merge, a new descriptor is built there.
4003 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4004 ** It is used to identify and delimit the runs.
4006 ** In the heat of determining where q, the greater of the f1/f2 elements,
4007 ** belongs in the other list, b, t and p, represent bottom, top and probe
4008 ** locations, respectively, in the other list.
4009 ** They make convenient temporary pointers in other places.
4013 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4017 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4018 gptr *aux, *list2, *p2, *last;
4022 if (nmemb <= 1) return; /* sorted trivially */
4023 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4025 dynprep(aTHX_ list1, list2, nmemb, cmp);
4026 last = PINDEX(list2, nmemb);
4027 while (NEXT(list2) != last) {
4028 /* More than one run remains. Do some merging to reduce runs. */
4030 for (tp2 = p2 = list2; p2 != last;) {
4031 /* The new first run begins where the old second list ended.
4032 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4036 f2 = l1 = POTHER(t, list2, list1);
4037 if (t != last) t = NEXT(t);
4038 l2 = POTHER(t, list2, list1);
4040 while (f1 < l1 && f2 < l2) {
4041 /* If head 1 is larger than head 2, find ALL the elements
4042 ** in list 2 strictly less than head1, write them all,
4043 ** then head 1. Then compare the new heads, and repeat,
4044 ** until one or both lists are exhausted.
4046 ** In all comparisons (after establishing
4047 ** which head to merge) the item to merge
4048 ** (at pointer q) is the first operand of
4049 ** the comparison. When we want to know
4050 ** if ``q is strictly less than the other'',
4052 ** cmp(q, other) < 0
4053 ** because stability demands that we treat equality
4054 ** as high when q comes from l2, and as low when
4055 ** q was from l1. So we ask the question by doing
4056 ** cmp(q, other) <= sense
4057 ** and make sense == 0 when equality should look low,
4058 ** and -1 when equality should look high.
4062 if (cmp(aTHX_ *f1, *f2) <= 0) {
4063 q = f2; b = f1; t = l1;
4066 q = f1; b = f2; t = l2;
4073 ** Leave t at something strictly
4074 ** greater than q (or at the end of the list),
4075 ** and b at something strictly less than q.
4077 for (i = 1, run = 0 ;;) {
4078 if ((p = PINDEX(b, i)) >= t) {
4080 if (((p = PINDEX(t, -1)) > b) &&
4081 (cmp(aTHX_ *q, *p) <= sense))
4085 } else if (cmp(aTHX_ *q, *p) <= sense) {
4089 if (++run >= RTHRESH) i += i;
4093 /* q is known to follow b and must be inserted before t.
4094 ** Increment b, so the range of possibilities is [b,t).
4095 ** Round binary split down, to favor early appearance.
4096 ** Adjust b and t until q belongs just before t.
4101 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4102 if (cmp(aTHX_ *q, *p) <= sense) {
4108 /* Copy all the strictly low elements */
4111 FROMTOUPTO(f2, tp2, t);
4114 FROMTOUPTO(f1, tp2, t);
4120 /* Run out remaining list */
4122 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4123 } else FROMTOUPTO(f1, tp2, l1);
4124 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4129 last = PINDEX(list2, nmemb);
4131 if (base == list2) {
4132 last = PINDEX(list1, nmemb);
4133 FROMTOUPTO(list1, list2, last);
4148 sortcv(pTHXo_ SV *a, SV *b)
4151 I32 oldsaveix = PL_savestack_ix;
4152 I32 oldscopeix = PL_scopestack_ix;
4154 GvSV(PL_firstgv) = a;
4155 GvSV(PL_secondgv) = b;
4156 PL_stack_sp = PL_stack_base;
4159 if (PL_stack_sp != PL_stack_base + 1)
4160 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4161 if (!SvNIOKp(*PL_stack_sp))
4162 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4163 result = SvIV(*PL_stack_sp);
4164 while (PL_scopestack_ix > oldscopeix) {
4167 leave_scope(oldsaveix);
4172 sortcv_stacked(pTHXo_ SV *a, SV *b)
4175 I32 oldsaveix = PL_savestack_ix;
4176 I32 oldscopeix = PL_scopestack_ix;
4181 av = (AV*)PL_curpad[0];
4183 av = GvAV(PL_defgv);
4186 if (AvMAX(av) < 1) {
4187 SV** ary = AvALLOC(av);
4188 if (AvARRAY(av) != ary) {
4189 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4190 SvPVX(av) = (char*)ary;
4192 if (AvMAX(av) < 1) {
4195 SvPVX(av) = (char*)ary;
4202 PL_stack_sp = PL_stack_base;
4205 if (PL_stack_sp != PL_stack_base + 1)
4206 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4207 if (!SvNIOKp(*PL_stack_sp))
4208 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4209 result = SvIV(*PL_stack_sp);
4210 while (PL_scopestack_ix > oldscopeix) {
4213 leave_scope(oldsaveix);
4218 sortcv_xsub(pTHXo_ SV *a, SV *b)
4221 I32 oldsaveix = PL_savestack_ix;
4222 I32 oldscopeix = PL_scopestack_ix;
4224 CV *cv=(CV*)PL_sortcop;
4232 (void)(*CvXSUB(cv))(aTHXo_ cv);
4233 if (PL_stack_sp != PL_stack_base + 1)
4234 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4235 if (!SvNIOKp(*PL_stack_sp))
4236 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4237 result = SvIV(*PL_stack_sp);
4238 while (PL_scopestack_ix > oldscopeix) {
4241 leave_scope(oldsaveix);
4247 sv_ncmp(pTHXo_ SV *a, SV *b)
4251 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4255 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4259 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4261 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4263 if (PL_amagic_generation) { \
4264 if (SvAMAGIC(left)||SvAMAGIC(right))\
4265 *svp = amagic_call(left, \
4273 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4276 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4281 I32 i = SvIVX(tmpsv);
4291 return sv_ncmp(aTHXo_ a, b);
4295 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4298 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4303 I32 i = SvIVX(tmpsv);
4313 return sv_i_ncmp(aTHXo_ a, b);
4317 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4320 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4325 I32 i = SvIVX(tmpsv);
4335 return sv_cmp(str1, str2);
4339 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4342 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4347 I32 i = SvIVX(tmpsv);
4357 return sv_cmp_locale(str1, str2);
4361 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4363 SV *datasv = FILTER_DATA(idx);
4364 int filter_has_file = IoLINES(datasv);
4365 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4366 SV *filter_state = (SV *)IoTOP_GV(datasv);
4367 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4370 /* I was having segfault trouble under Linux 2.2.5 after a
4371 parse error occured. (Had to hack around it with a test
4372 for PL_error_count == 0.) Solaris doesn't segfault --
4373 not sure where the trouble is yet. XXX */
4375 if (filter_has_file) {
4376 len = FILTER_READ(idx+1, buf_sv, maxlen);
4379 if (filter_sub && len >= 0) {
4390 PUSHs(sv_2mortal(newSViv(maxlen)));
4392 PUSHs(filter_state);
4395 count = call_sv(filter_sub, G_SCALAR);
4411 IoLINES(datasv) = 0;
4412 if (filter_child_proc) {
4413 SvREFCNT_dec(filter_child_proc);
4414 IoFMT_GV(datasv) = Nullgv;
4417 SvREFCNT_dec(filter_state);
4418 IoTOP_GV(datasv) = Nullgv;
4421 SvREFCNT_dec(filter_sub);
4422 IoBOTTOM_GV(datasv) = Nullgv;
4424 filter_del(run_user_filter);
4433 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4435 return sv_cmp_locale(str1, str2);
4439 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4441 return sv_cmp(str1, str2);
4444 #endif /* PERL_OBJECT */