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)
1164 register PERL_CONTEXT *cx;
1166 for (i = cxstack_ix; i >= 0; i--) {
1168 switch (CxTYPE(cx)) {
1170 if (ckWARN(WARN_EXITING))
1171 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1172 PL_op_name[PL_op->op_type]);
1175 if (ckWARN(WARN_EXITING))
1176 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1177 PL_op_name[PL_op->op_type]);
1180 if (ckWARN(WARN_EXITING))
1181 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1182 PL_op_name[PL_op->op_type]);
1185 if (ckWARN(WARN_EXITING))
1186 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1187 PL_op_name[PL_op->op_type]);
1190 if (ckWARN(WARN_EXITING))
1191 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1192 PL_op_name[PL_op->op_type]);
1195 if (!cx->blk_loop.label ||
1196 strNE(label, cx->blk_loop.label) ) {
1197 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1198 (long)i, cx->blk_loop.label));
1201 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1209 Perl_dowantarray(pTHX)
1211 I32 gimme = block_gimme();
1212 return (gimme == G_VOID) ? G_SCALAR : gimme;
1216 Perl_block_gimme(pTHX)
1220 cxix = dopoptosub(cxstack_ix);
1224 switch (cxstack[cxix].blk_gimme) {
1232 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1239 S_dopoptosub(pTHX_ I32 startingblock)
1241 return dopoptosub_at(cxstack, startingblock);
1245 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1248 register PERL_CONTEXT *cx;
1249 for (i = startingblock; i >= 0; i--) {
1251 switch (CxTYPE(cx)) {
1257 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1265 S_dopoptoeval(pTHX_ I32 startingblock)
1268 register PERL_CONTEXT *cx;
1269 for (i = startingblock; i >= 0; i--) {
1271 switch (CxTYPE(cx)) {
1275 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1283 S_dopoptoloop(pTHX_ I32 startingblock)
1286 register PERL_CONTEXT *cx;
1287 for (i = startingblock; i >= 0; i--) {
1289 switch (CxTYPE(cx)) {
1291 if (ckWARN(WARN_EXITING))
1292 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1293 PL_op_name[PL_op->op_type]);
1296 if (ckWARN(WARN_EXITING))
1297 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1298 PL_op_name[PL_op->op_type]);
1301 if (ckWARN(WARN_EXITING))
1302 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1303 PL_op_name[PL_op->op_type]);
1306 if (ckWARN(WARN_EXITING))
1307 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1308 PL_op_name[PL_op->op_type]);
1311 if (ckWARN(WARN_EXITING))
1312 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1313 PL_op_name[PL_op->op_type]);
1316 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1324 Perl_dounwind(pTHX_ I32 cxix)
1326 register PERL_CONTEXT *cx;
1329 while (cxstack_ix > cxix) {
1331 cx = &cxstack[cxstack_ix];
1332 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1333 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1334 /* Note: we don't need to restore the base context info till the end. */
1335 switch (CxTYPE(cx)) {
1338 continue; /* not break */
1360 * Closures mentioned at top level of eval cannot be referenced
1361 * again, and their presence indirectly causes a memory leak.
1362 * (Note that the fact that compcv and friends are still set here
1363 * is, AFAIK, an accident.) --Chip
1365 * XXX need to get comppad et al from eval's cv rather than
1366 * relying on the incidental global values.
1369 S_free_closures(pTHX)
1371 SV **svp = AvARRAY(PL_comppad_name);
1373 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1375 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1377 svp[ix] = &PL_sv_undef;
1381 SvREFCNT_dec(CvOUTSIDE(sv));
1382 CvOUTSIDE(sv) = Nullcv;
1395 Perl_qerror(pTHX_ SV *err)
1398 sv_catsv(ERRSV, err);
1400 sv_catsv(PL_errors, err);
1402 Perl_warn(aTHX_ "%"SVf, err);
1407 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1412 register PERL_CONTEXT *cx;
1417 if (PL_in_eval & EVAL_KEEPERR) {
1418 static char prefix[] = "\t(in cleanup) ";
1423 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1426 if (*e != *message || strNE(e,message))
1430 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1431 sv_catpvn(err, prefix, sizeof(prefix)-1);
1432 sv_catpvn(err, message, msglen);
1433 if (ckWARN(WARN_MISC)) {
1434 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1435 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1440 sv_setpvn(ERRSV, message, msglen);
1443 message = SvPVx(ERRSV, msglen);
1445 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1446 && PL_curstackinfo->si_prev)
1455 if (cxix < cxstack_ix)
1458 POPBLOCK(cx,PL_curpm);
1459 if (CxTYPE(cx) != CXt_EVAL) {
1460 PerlIO_write(Perl_error_log, "panic: die ", 11);
1461 PerlIO_write(Perl_error_log, message, msglen);
1466 if (gimme == G_SCALAR)
1467 *++newsp = &PL_sv_undef;
1468 PL_stack_sp = newsp;
1472 /* LEAVE could clobber PL_curcop (see save_re_context())
1473 * XXX it might be better to find a way to avoid messing with
1474 * PL_curcop in save_re_context() instead, but this is a more
1475 * minimal fix --GSAR */
1476 PL_curcop = cx->blk_oldcop;
1478 if (optype == OP_REQUIRE) {
1479 char* msg = SvPVx(ERRSV, n_a);
1480 DIE(aTHX_ "%sCompilation failed in require",
1481 *msg ? msg : "Unknown error\n");
1483 return pop_return();
1487 message = SvPVx(ERRSV, msglen);
1490 /* SFIO can really mess with your errno */
1493 PerlIO *serr = Perl_error_log;
1495 PerlIO_write(serr, message, msglen);
1496 (void)PerlIO_flush(serr);
1509 if (SvTRUE(left) != SvTRUE(right))
1521 RETURNOP(cLOGOP->op_other);
1530 RETURNOP(cLOGOP->op_other);
1536 register I32 cxix = dopoptosub(cxstack_ix);
1537 register PERL_CONTEXT *cx;
1538 register PERL_CONTEXT *ccstack = cxstack;
1539 PERL_SI *top_si = PL_curstackinfo;
1550 /* we may be in a higher stacklevel, so dig down deeper */
1551 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1552 top_si = top_si->si_prev;
1553 ccstack = top_si->si_cxstack;
1554 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1557 if (GIMME != G_ARRAY)
1561 if (PL_DBsub && cxix >= 0 &&
1562 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1566 cxix = dopoptosub_at(ccstack, cxix - 1);
1569 cx = &ccstack[cxix];
1570 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1571 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1572 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1573 field below is defined for any cx. */
1574 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1575 cx = &ccstack[dbcxix];
1578 stashname = CopSTASHPV(cx->blk_oldcop);
1579 if (GIMME != G_ARRAY) {
1581 PUSHs(&PL_sv_undef);
1584 sv_setpv(TARG, stashname);
1591 PUSHs(&PL_sv_undef);
1593 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1594 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1595 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1598 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1599 /* So is ccstack[dbcxix]. */
1601 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1602 PUSHs(sv_2mortal(sv));
1603 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1606 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1607 PUSHs(sv_2mortal(newSViv(0)));
1609 gimme = (I32)cx->blk_gimme;
1610 if (gimme == G_VOID)
1611 PUSHs(&PL_sv_undef);
1613 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1614 if (CxTYPE(cx) == CXt_EVAL) {
1616 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1617 PUSHs(cx->blk_eval.cur_text);
1621 else if (cx->blk_eval.old_namesv) {
1622 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1625 /* eval BLOCK (try blocks have old_namesv == 0) */
1627 PUSHs(&PL_sv_undef);
1628 PUSHs(&PL_sv_undef);
1632 PUSHs(&PL_sv_undef);
1633 PUSHs(&PL_sv_undef);
1635 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1636 && CopSTASH_eq(PL_curcop, PL_debstash))
1638 AV *ary = cx->blk_sub.argarray;
1639 int off = AvARRAY(ary) - AvALLOC(ary);
1643 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1646 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1649 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1650 av_extend(PL_dbargs, AvFILLp(ary) + off);
1651 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1652 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1654 /* XXX only hints propagated via op_private are currently
1655 * visible (others are not easily accessible, since they
1656 * use the global PL_hints) */
1657 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1658 HINT_PRIVATE_MASK)));
1661 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1663 if (old_warnings == pWARN_NONE ||
1664 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1665 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1666 else if (old_warnings == pWARN_ALL ||
1667 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1668 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1670 mask = newSVsv(old_warnings);
1671 PUSHs(sv_2mortal(mask));
1686 sv_reset(tmps, CopSTASH(PL_curcop));
1698 PL_curcop = (COP*)PL_op;
1699 TAINT_NOT; /* Each statement is presumed innocent */
1700 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1703 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1707 register PERL_CONTEXT *cx;
1708 I32 gimme = G_ARRAY;
1715 DIE(aTHX_ "No DB::DB routine defined");
1717 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1729 push_return(PL_op->op_next);
1730 PUSHBLOCK(cx, CXt_SUB, SP);
1733 (void)SvREFCNT_inc(cv);
1734 SAVEVPTR(PL_curpad);
1735 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1736 RETURNOP(CvSTART(cv));
1750 register PERL_CONTEXT *cx;
1751 I32 gimme = GIMME_V;
1753 U32 cxtype = CXt_LOOP;
1762 if (PL_op->op_flags & OPf_SPECIAL) {
1763 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1764 SAVEGENERICSV(*svp);
1768 #endif /* USE_THREADS */
1769 if (PL_op->op_targ) {
1770 #ifndef USE_ITHREADS
1771 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1774 SAVEPADSV(PL_op->op_targ);
1775 iterdata = (void*)PL_op->op_targ;
1776 cxtype |= CXp_PADVAR;
1781 svp = &GvSV(gv); /* symbol table variable */
1782 SAVEGENERICSV(*svp);
1785 iterdata = (void*)gv;
1791 PUSHBLOCK(cx, cxtype, SP);
1793 PUSHLOOP(cx, iterdata, MARK);
1795 PUSHLOOP(cx, svp, MARK);
1797 if (PL_op->op_flags & OPf_STACKED) {
1798 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1799 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1801 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1802 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1803 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1804 looks_like_number((SV*)cx->blk_loop.iterary) &&
1805 *SvPVX(cx->blk_loop.iterary) != '0'))
1807 if (SvNV(sv) < IV_MIN ||
1808 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1809 DIE(aTHX_ "Range iterator outside integer range");
1810 cx->blk_loop.iterix = SvIV(sv);
1811 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1814 cx->blk_loop.iterlval = newSVsv(sv);
1818 cx->blk_loop.iterary = PL_curstack;
1819 AvFILLp(PL_curstack) = SP - PL_stack_base;
1820 cx->blk_loop.iterix = MARK - PL_stack_base;
1829 register PERL_CONTEXT *cx;
1830 I32 gimme = GIMME_V;
1836 PUSHBLOCK(cx, CXt_LOOP, SP);
1837 PUSHLOOP(cx, 0, SP);
1845 register PERL_CONTEXT *cx;
1853 newsp = PL_stack_base + cx->blk_loop.resetsp;
1856 if (gimme == G_VOID)
1858 else if (gimme == G_SCALAR) {
1860 *++newsp = sv_mortalcopy(*SP);
1862 *++newsp = &PL_sv_undef;
1866 *++newsp = sv_mortalcopy(*++mark);
1867 TAINT_NOT; /* Each item is independent */
1873 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1874 PL_curpm = newpm; /* ... and pop $1 et al */
1886 register PERL_CONTEXT *cx;
1887 bool popsub2 = FALSE;
1888 bool clear_errsv = FALSE;
1895 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1896 if (cxstack_ix == PL_sortcxix
1897 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1899 if (cxstack_ix > PL_sortcxix)
1900 dounwind(PL_sortcxix);
1901 AvARRAY(PL_curstack)[1] = *SP;
1902 PL_stack_sp = PL_stack_base + 1;
1907 cxix = dopoptosub(cxstack_ix);
1909 DIE(aTHX_ "Can't return outside a subroutine");
1910 if (cxix < cxstack_ix)
1914 switch (CxTYPE(cx)) {
1919 if (!(PL_in_eval & EVAL_KEEPERR))
1924 if (AvFILLp(PL_comppad_name) >= 0)
1927 if (optype == OP_REQUIRE &&
1928 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1930 /* Unassume the success we assumed earlier. */
1931 SV *nsv = cx->blk_eval.old_namesv;
1932 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1933 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1940 DIE(aTHX_ "panic: return");
1944 if (gimme == G_SCALAR) {
1947 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1949 *++newsp = SvREFCNT_inc(*SP);
1954 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1956 *++newsp = sv_mortalcopy(sv);
1961 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1964 *++newsp = sv_mortalcopy(*SP);
1967 *++newsp = &PL_sv_undef;
1969 else if (gimme == G_ARRAY) {
1970 while (++MARK <= SP) {
1971 *++newsp = (popsub2 && SvTEMP(*MARK))
1972 ? *MARK : sv_mortalcopy(*MARK);
1973 TAINT_NOT; /* Each item is independent */
1976 PL_stack_sp = newsp;
1978 /* Stack values are safe: */
1980 POPSUB(cx,sv); /* release CV and @_ ... */
1984 PL_curpm = newpm; /* ... and pop $1 et al */
1990 return pop_return();
1997 register PERL_CONTEXT *cx;
2007 if (PL_op->op_flags & OPf_SPECIAL) {
2008 cxix = dopoptoloop(cxstack_ix);
2010 DIE(aTHX_ "Can't \"last\" outside a loop block");
2013 cxix = dopoptolabel(cPVOP->op_pv);
2015 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2017 if (cxix < cxstack_ix)
2022 switch (CxTYPE(cx)) {
2025 newsp = PL_stack_base + cx->blk_loop.resetsp;
2026 nextop = cx->blk_loop.last_op->op_next;
2030 nextop = pop_return();
2034 nextop = pop_return();
2038 nextop = pop_return();
2041 DIE(aTHX_ "panic: last");
2045 if (gimme == G_SCALAR) {
2047 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2048 ? *SP : sv_mortalcopy(*SP);
2050 *++newsp = &PL_sv_undef;
2052 else if (gimme == G_ARRAY) {
2053 while (++MARK <= SP) {
2054 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2055 ? *MARK : sv_mortalcopy(*MARK);
2056 TAINT_NOT; /* Each item is independent */
2062 /* Stack values are safe: */
2065 POPLOOP(cx); /* release loop vars ... */
2069 POPSUB(cx,sv); /* release CV and @_ ... */
2072 PL_curpm = newpm; /* ... and pop $1 et al */
2082 register PERL_CONTEXT *cx;
2085 if (PL_op->op_flags & OPf_SPECIAL) {
2086 cxix = dopoptoloop(cxstack_ix);
2088 DIE(aTHX_ "Can't \"next\" outside a loop block");
2091 cxix = dopoptolabel(cPVOP->op_pv);
2093 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2095 if (cxix < cxstack_ix)
2098 /* clear off anything above the scope we're re-entering, but
2099 * save the rest until after a possible continue block */
2100 inner = PL_scopestack_ix;
2102 if (PL_scopestack_ix < inner)
2103 leave_scope(PL_scopestack[PL_scopestack_ix]);
2104 return cx->blk_loop.next_op;
2110 register PERL_CONTEXT *cx;
2113 if (PL_op->op_flags & OPf_SPECIAL) {
2114 cxix = dopoptoloop(cxstack_ix);
2116 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2119 cxix = dopoptolabel(cPVOP->op_pv);
2121 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2123 if (cxix < cxstack_ix)
2127 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2128 LEAVE_SCOPE(oldsave);
2129 return cx->blk_loop.redo_op;
2133 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2137 static char too_deep[] = "Target of goto is too deeply nested";
2140 Perl_croak(aTHX_ too_deep);
2141 if (o->op_type == OP_LEAVE ||
2142 o->op_type == OP_SCOPE ||
2143 o->op_type == OP_LEAVELOOP ||
2144 o->op_type == OP_LEAVETRY)
2146 *ops++ = cUNOPo->op_first;
2148 Perl_croak(aTHX_ too_deep);
2151 if (o->op_flags & OPf_KIDS) {
2152 /* First try all the kids at this level, since that's likeliest. */
2153 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2154 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2155 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2159 if (kid == PL_lastgotoprobe)
2161 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2163 (ops[-1]->op_type != OP_NEXTSTATE &&
2164 ops[-1]->op_type != OP_DBSTATE)))
2166 if ((o = dofindlabel(kid, label, ops, oplimit)))
2185 register PERL_CONTEXT *cx;
2186 #define GOTO_DEPTH 64
2187 OP *enterops[GOTO_DEPTH];
2189 int do_dump = (PL_op->op_type == OP_DUMP);
2190 static char must_have_label[] = "goto must have label";
2193 if (PL_op->op_flags & OPf_STACKED) {
2197 /* This egregious kludge implements goto &subroutine */
2198 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2200 register PERL_CONTEXT *cx;
2201 CV* cv = (CV*)SvRV(sv);
2207 if (!CvROOT(cv) && !CvXSUB(cv)) {
2212 /* autoloaded stub? */
2213 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2215 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2216 GvNAMELEN(gv), FALSE);
2217 if (autogv && (cv = GvCV(autogv)))
2219 tmpstr = sv_newmortal();
2220 gv_efullname3(tmpstr, gv, Nullch);
2221 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2223 DIE(aTHX_ "Goto undefined subroutine");
2226 /* First do some returnish stuff. */
2227 cxix = dopoptosub(cxstack_ix);
2229 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2230 if (cxix < cxstack_ix)
2233 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2234 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2236 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2237 /* put @_ back onto stack */
2238 AV* av = cx->blk_sub.argarray;
2240 items = AvFILLp(av) + 1;
2242 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2243 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2244 PL_stack_sp += items;
2246 SvREFCNT_dec(GvAV(PL_defgv));
2247 GvAV(PL_defgv) = cx->blk_sub.savearray;
2248 #endif /* USE_THREADS */
2249 /* abandon @_ if it got reified */
2251 (void)sv_2mortal((SV*)av); /* delay until return */
2253 av_extend(av, items-1);
2254 AvFLAGS(av) = AVf_REIFY;
2255 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2258 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2261 av = (AV*)PL_curpad[0];
2263 av = GvAV(PL_defgv);
2265 items = AvFILLp(av) + 1;
2267 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2268 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2269 PL_stack_sp += items;
2271 if (CxTYPE(cx) == CXt_SUB &&
2272 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2273 SvREFCNT_dec(cx->blk_sub.cv);
2274 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2275 LEAVE_SCOPE(oldsave);
2277 /* Now do some callish stuff. */
2280 #ifdef PERL_XSUB_OLDSTYLE
2281 if (CvOLDSTYLE(cv)) {
2282 I32 (*fp3)(int,int,int);
2287 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2288 items = (*fp3)(CvXSUBANY(cv).any_i32,
2289 mark - PL_stack_base + 1,
2291 SP = PL_stack_base + items;
2294 #endif /* PERL_XSUB_OLDSTYLE */
2299 PL_stack_sp--; /* There is no cv arg. */
2300 /* Push a mark for the start of arglist */
2302 (void)(*CvXSUB(cv))(aTHXo_ cv);
2303 /* Pop the current context like a decent sub should */
2304 POPBLOCK(cx, PL_curpm);
2305 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2308 return pop_return();
2311 AV* padlist = CvPADLIST(cv);
2312 SV** svp = AvARRAY(padlist);
2313 if (CxTYPE(cx) == CXt_EVAL) {
2314 PL_in_eval = cx->blk_eval.old_in_eval;
2315 PL_eval_root = cx->blk_eval.old_eval_root;
2316 cx->cx_type = CXt_SUB;
2317 cx->blk_sub.hasargs = 0;
2319 cx->blk_sub.cv = cv;
2320 cx->blk_sub.olddepth = CvDEPTH(cv);
2322 if (CvDEPTH(cv) < 2)
2323 (void)SvREFCNT_inc(cv);
2324 else { /* save temporaries on recursion? */
2325 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2326 sub_crush_depth(cv);
2327 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2328 AV *newpad = newAV();
2329 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2330 I32 ix = AvFILLp((AV*)svp[1]);
2331 I32 names_fill = AvFILLp((AV*)svp[0]);
2332 svp = AvARRAY(svp[0]);
2333 for ( ;ix > 0; ix--) {
2334 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2335 char *name = SvPVX(svp[ix]);
2336 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2339 /* outer lexical or anon code */
2340 av_store(newpad, ix,
2341 SvREFCNT_inc(oldpad[ix]) );
2343 else { /* our own lexical */
2345 av_store(newpad, ix, sv = (SV*)newAV());
2346 else if (*name == '%')
2347 av_store(newpad, ix, sv = (SV*)newHV());
2349 av_store(newpad, ix, sv = NEWSV(0,0));
2353 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2354 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2357 av_store(newpad, ix, sv = NEWSV(0,0));
2361 if (cx->blk_sub.hasargs) {
2364 av_store(newpad, 0, (SV*)av);
2365 AvFLAGS(av) = AVf_REIFY;
2367 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2368 AvFILLp(padlist) = CvDEPTH(cv);
2369 svp = AvARRAY(padlist);
2373 if (!cx->blk_sub.hasargs) {
2374 AV* av = (AV*)PL_curpad[0];
2376 items = AvFILLp(av) + 1;
2378 /* Mark is at the end of the stack. */
2380 Copy(AvARRAY(av), SP + 1, items, SV*);
2385 #endif /* USE_THREADS */
2386 SAVEVPTR(PL_curpad);
2387 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2389 if (cx->blk_sub.hasargs)
2390 #endif /* USE_THREADS */
2392 AV* av = (AV*)PL_curpad[0];
2396 cx->blk_sub.savearray = GvAV(PL_defgv);
2397 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2398 #endif /* USE_THREADS */
2399 cx->blk_sub.oldcurpad = PL_curpad;
2400 cx->blk_sub.argarray = av;
2403 if (items >= AvMAX(av) + 1) {
2405 if (AvARRAY(av) != ary) {
2406 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407 SvPVX(av) = (char*)ary;
2409 if (items >= AvMAX(av) + 1) {
2410 AvMAX(av) = items - 1;
2411 Renew(ary,items+1,SV*);
2413 SvPVX(av) = (char*)ary;
2416 Copy(mark,AvARRAY(av),items,SV*);
2417 AvFILLp(av) = items - 1;
2418 assert(!AvREAL(av));
2425 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2427 * We do not care about using sv to call CV;
2428 * it's for informational purposes only.
2430 SV *sv = GvSV(PL_DBsub);
2433 if (PERLDB_SUB_NN) {
2434 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2437 gv_efullname3(sv, CvGV(cv), Nullch);
2440 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2441 PUSHMARK( PL_stack_sp );
2442 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2446 RETURNOP(CvSTART(cv));
2450 label = SvPV(sv,n_a);
2451 if (!(do_dump || *label))
2452 DIE(aTHX_ must_have_label);
2455 else if (PL_op->op_flags & OPf_SPECIAL) {
2457 DIE(aTHX_ must_have_label);
2460 label = cPVOP->op_pv;
2462 if (label && *label) {
2467 PL_lastgotoprobe = 0;
2469 for (ix = cxstack_ix; ix >= 0; ix--) {
2471 switch (CxTYPE(cx)) {
2473 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2476 gotoprobe = cx->blk_oldcop->op_sibling;
2482 gotoprobe = cx->blk_oldcop->op_sibling;
2484 gotoprobe = PL_main_root;
2487 if (CvDEPTH(cx->blk_sub.cv)) {
2488 gotoprobe = CvROOT(cx->blk_sub.cv);
2494 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2497 DIE(aTHX_ "panic: goto");
2498 gotoprobe = PL_main_root;
2502 retop = dofindlabel(gotoprobe, label,
2503 enterops, enterops + GOTO_DEPTH);
2507 PL_lastgotoprobe = gotoprobe;
2510 DIE(aTHX_ "Can't find label %s", label);
2512 /* pop unwanted frames */
2514 if (ix < cxstack_ix) {
2521 oldsave = PL_scopestack[PL_scopestack_ix];
2522 LEAVE_SCOPE(oldsave);
2525 /* push wanted frames */
2527 if (*enterops && enterops[1]) {
2529 for (ix = 1; enterops[ix]; ix++) {
2530 PL_op = enterops[ix];
2531 /* Eventually we may want to stack the needed arguments
2532 * for each op. For now, we punt on the hard ones. */
2533 if (PL_op->op_type == OP_ENTERITER)
2534 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2535 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2543 if (!retop) retop = PL_main_start;
2545 PL_restartop = retop;
2546 PL_do_undump = TRUE;
2550 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2551 PL_do_undump = FALSE;
2567 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2571 PL_exit_flags |= PERL_EXIT_EXPECTED;
2573 PUSHs(&PL_sv_undef);
2581 NV value = SvNVx(GvSV(cCOP->cop_gv));
2582 register I32 match = I_32(value);
2585 if (((NV)match) > value)
2586 --match; /* was fractional--truncate other way */
2588 match -= cCOP->uop.scop.scop_offset;
2591 else if (match > cCOP->uop.scop.scop_max)
2592 match = cCOP->uop.scop.scop_max;
2593 PL_op = cCOP->uop.scop.scop_next[match];
2603 PL_op = PL_op->op_next; /* can't assume anything */
2606 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2607 match -= cCOP->uop.scop.scop_offset;
2610 else if (match > cCOP->uop.scop.scop_max)
2611 match = cCOP->uop.scop.scop_max;
2612 PL_op = cCOP->uop.scop.scop_next[match];
2621 S_save_lines(pTHX_ AV *array, SV *sv)
2623 register char *s = SvPVX(sv);
2624 register char *send = SvPVX(sv) + SvCUR(sv);
2626 register I32 line = 1;
2628 while (s && s < send) {
2629 SV *tmpstr = NEWSV(85,0);
2631 sv_upgrade(tmpstr, SVt_PVMG);
2632 t = strchr(s, '\n');
2638 sv_setpvn(tmpstr, s, t - s);
2639 av_store(array, line++, tmpstr);
2644 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2646 S_docatch_body(pTHX_ va_list args)
2648 return docatch_body();
2653 S_docatch_body(pTHX)
2660 S_docatch(pTHX_ OP *o)
2664 volatile PERL_SI *cursi = PL_curstackinfo;
2668 assert(CATCH_GET == TRUE);
2671 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2673 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2679 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2685 if (PL_restartop && cursi == PL_curstackinfo) {
2686 PL_op = PL_restartop;
2703 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2704 /* sv Text to convert to OP tree. */
2705 /* startop op_free() this to undo. */
2706 /* code Short string id of the caller. */
2708 dSP; /* Make POPBLOCK work. */
2711 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2715 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2716 char *tmpbuf = tbuf;
2722 /* switch to eval mode */
2724 if (PL_curcop == &PL_compiling) {
2725 SAVECOPSTASH_FREE(&PL_compiling);
2726 CopSTASH_set(&PL_compiling, PL_curstash);
2728 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2729 SV *sv = sv_newmortal();
2730 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2731 code, (unsigned long)++PL_evalseq,
2732 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2736 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2737 SAVECOPFILE_FREE(&PL_compiling);
2738 CopFILE_set(&PL_compiling, tmpbuf+2);
2739 SAVECOPLINE(&PL_compiling);
2740 CopLINE_set(&PL_compiling, 1);
2741 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2742 deleting the eval's FILEGV from the stash before gv_check() runs
2743 (i.e. before run-time proper). To work around the coredump that
2744 ensues, we always turn GvMULTI_on for any globals that were
2745 introduced within evals. See force_ident(). GSAR 96-10-12 */
2746 safestr = savepv(tmpbuf);
2747 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2749 #ifdef OP_IN_REGISTER
2757 PL_op->op_type = OP_ENTEREVAL;
2758 PL_op->op_flags = 0; /* Avoid uninit warning. */
2759 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2760 PUSHEVAL(cx, 0, Nullgv);
2761 rop = doeval(G_SCALAR, startop);
2762 POPBLOCK(cx,PL_curpm);
2765 (*startop)->op_type = OP_NULL;
2766 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2768 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2770 if (PL_curcop == &PL_compiling)
2771 PL_compiling.op_private = PL_hints;
2772 #ifdef OP_IN_REGISTER
2778 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2780 S_doeval(pTHX_ int gimme, OP** startop)
2788 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2789 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2794 /* set up a scratch pad */
2797 SAVEVPTR(PL_curpad);
2798 SAVESPTR(PL_comppad);
2799 SAVESPTR(PL_comppad_name);
2800 SAVEI32(PL_comppad_name_fill);
2801 SAVEI32(PL_min_intro_pending);
2802 SAVEI32(PL_max_intro_pending);
2805 for (i = cxstack_ix - 1; i >= 0; i--) {
2806 PERL_CONTEXT *cx = &cxstack[i];
2807 if (CxTYPE(cx) == CXt_EVAL)
2809 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2810 caller = cx->blk_sub.cv;
2815 SAVESPTR(PL_compcv);
2816 PL_compcv = (CV*)NEWSV(1104,0);
2817 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2818 CvEVAL_on(PL_compcv);
2820 CvOWNER(PL_compcv) = 0;
2821 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2822 MUTEX_INIT(CvMUTEXP(PL_compcv));
2823 #endif /* USE_THREADS */
2825 PL_comppad = newAV();
2826 av_push(PL_comppad, Nullsv);
2827 PL_curpad = AvARRAY(PL_comppad);
2828 PL_comppad_name = newAV();
2829 PL_comppad_name_fill = 0;
2830 PL_min_intro_pending = 0;
2833 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2834 PL_curpad[0] = (SV*)newAV();
2835 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2836 #endif /* USE_THREADS */
2838 comppadlist = newAV();
2839 AvREAL_off(comppadlist);
2840 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2841 av_store(comppadlist, 1, (SV*)PL_comppad);
2842 CvPADLIST(PL_compcv) = comppadlist;
2845 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2847 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2850 SAVEFREESV(PL_compcv);
2852 /* make sure we compile in the right package */
2854 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2855 SAVESPTR(PL_curstash);
2856 PL_curstash = CopSTASH(PL_curcop);
2858 SAVESPTR(PL_beginav);
2859 PL_beginav = newAV();
2860 SAVEFREESV(PL_beginav);
2861 SAVEI32(PL_error_count);
2863 /* try to compile it */
2865 PL_eval_root = Nullop;
2867 PL_curcop = &PL_compiling;
2868 PL_curcop->cop_arybase = 0;
2869 SvREFCNT_dec(PL_rs);
2870 PL_rs = newSVpvn("\n", 1);
2871 if (saveop && saveop->op_flags & OPf_SPECIAL)
2872 PL_in_eval |= EVAL_KEEPERR;
2875 if (yyparse() || PL_error_count || !PL_eval_root) {
2879 I32 optype = 0; /* Might be reset by POPEVAL. */
2884 op_free(PL_eval_root);
2885 PL_eval_root = Nullop;
2887 SP = PL_stack_base + POPMARK; /* pop original mark */
2889 POPBLOCK(cx,PL_curpm);
2895 if (optype == OP_REQUIRE) {
2896 char* msg = SvPVx(ERRSV, n_a);
2897 DIE(aTHX_ "%sCompilation failed in require",
2898 *msg ? msg : "Unknown error\n");
2901 char* msg = SvPVx(ERRSV, n_a);
2903 POPBLOCK(cx,PL_curpm);
2905 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2906 (*msg ? msg : "Unknown error\n"));
2908 SvREFCNT_dec(PL_rs);
2909 PL_rs = SvREFCNT_inc(PL_nrs);
2911 MUTEX_LOCK(&PL_eval_mutex);
2913 COND_SIGNAL(&PL_eval_cond);
2914 MUTEX_UNLOCK(&PL_eval_mutex);
2915 #endif /* USE_THREADS */
2918 SvREFCNT_dec(PL_rs);
2919 PL_rs = SvREFCNT_inc(PL_nrs);
2920 CopLINE_set(&PL_compiling, 0);
2922 *startop = PL_eval_root;
2923 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2924 CvOUTSIDE(PL_compcv) = Nullcv;
2926 SAVEFREEOP(PL_eval_root);
2928 scalarvoid(PL_eval_root);
2929 else if (gimme & G_ARRAY)
2932 scalar(PL_eval_root);
2934 DEBUG_x(dump_eval());
2936 /* Register with debugger: */
2937 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2938 CV *cv = get_cv("DB::postponed", FALSE);
2942 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2944 call_sv((SV*)cv, G_DISCARD);
2948 /* compiled okay, so do it */
2950 CvDEPTH(PL_compcv) = 1;
2951 SP = PL_stack_base + POPMARK; /* pop original mark */
2952 PL_op = saveop; /* The caller may need it. */
2953 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2955 MUTEX_LOCK(&PL_eval_mutex);
2957 COND_SIGNAL(&PL_eval_cond);
2958 MUTEX_UNLOCK(&PL_eval_mutex);
2959 #endif /* USE_THREADS */
2961 RETURNOP(PL_eval_start);
2965 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2967 STRLEN namelen = strlen(name);
2970 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2971 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2972 char *pmc = SvPV_nolen(pmcsv);
2975 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2976 fp = PerlIO_open(name, mode);
2979 if (PerlLIO_stat(name, &pmstat) < 0 ||
2980 pmstat.st_mtime < pmcstat.st_mtime)
2982 fp = PerlIO_open(pmc, mode);
2985 fp = PerlIO_open(name, mode);
2988 SvREFCNT_dec(pmcsv);
2991 fp = PerlIO_open(name, mode);
2999 register PERL_CONTEXT *cx;
3004 SV *namesv = Nullsv;
3006 I32 gimme = G_SCALAR;
3007 PerlIO *tryrsfp = 0;
3009 int filter_has_file = 0;
3010 GV *filter_child_proc = 0;
3011 SV *filter_state = 0;
3016 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3017 UV rev = 0, ver = 0, sver = 0;
3019 U8 *s = (U8*)SvPVX(sv);
3020 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3022 rev = utf8_to_uv(s, end - s, &len, 0);
3025 ver = utf8_to_uv(s, end - s, &len, 0);
3028 sver = utf8_to_uv(s, end - s, &len, 0);
3031 if (PERL_REVISION < rev
3032 || (PERL_REVISION == rev
3033 && (PERL_VERSION < ver
3034 || (PERL_VERSION == ver
3035 && PERL_SUBVERSION < sver))))
3037 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3038 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3039 PERL_VERSION, PERL_SUBVERSION);
3043 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3044 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3045 + ((NV)PERL_SUBVERSION/(NV)1000000)
3046 + 0.00000099 < SvNV(sv))
3050 NV nver = (nrev - rev) * 1000;
3051 UV ver = (UV)(nver + 0.0009);
3052 NV nsver = (nver - ver) * 1000;
3053 UV sver = (UV)(nsver + 0.0009);
3055 /* help out with the "use 5.6" confusion */
3056 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3057 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3058 "this is only v%d.%d.%d, stopped"
3059 " (did you mean v%"UVuf".%"UVuf".0?)",
3060 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3061 PERL_SUBVERSION, rev, ver/100);
3064 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3065 "this is only v%d.%d.%d, stopped",
3066 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3073 name = SvPV(sv, len);
3074 if (!(name && len > 0 && *name))
3075 DIE(aTHX_ "Null filename used");
3076 TAINT_PROPER("require");
3077 if (PL_op->op_type == OP_REQUIRE &&
3078 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3079 *svp != &PL_sv_undef)
3082 /* prepare to compile file */
3084 if (PERL_FILE_IS_ABSOLUTE(name)
3085 || (*name == '.' && (name[1] == '/' ||
3086 (name[1] == '.' && name[2] == '/'))))
3089 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3090 #ifdef MACOS_TRADITIONAL
3091 /* We consider paths of the form :a:b ambiguous and interpret them first
3092 as global then as local
3094 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3103 AV *ar = GvAVn(PL_incgv);
3107 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3110 namesv = NEWSV(806, 0);
3111 for (i = 0; i <= AvFILL(ar); i++) {
3112 SV *dirsv = *av_fetch(ar, i, TRUE);
3118 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3119 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3122 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3123 PTR2UV(SvANY(loader)), name);
3124 tryname = SvPVX(namesv);
3135 count = call_sv(loader, G_ARRAY);
3145 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3149 if (SvTYPE(arg) == SVt_PVGV) {
3150 IO *io = GvIO((GV *)arg);
3155 tryrsfp = IoIFP(io);
3156 if (IoTYPE(io) == IoTYPE_PIPE) {
3157 /* reading from a child process doesn't
3158 nest -- when returning from reading
3159 the inner module, the outer one is
3160 unreadable (closed?) I've tried to
3161 save the gv to manage the lifespan of
3162 the pipe, but this didn't help. XXX */
3163 filter_child_proc = (GV *)arg;
3164 (void)SvREFCNT_inc(filter_child_proc);
3167 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3168 PerlIO_close(IoOFP(io));
3180 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3182 (void)SvREFCNT_inc(filter_sub);
3185 filter_state = SP[i];
3186 (void)SvREFCNT_inc(filter_state);
3190 tryrsfp = PerlIO_open("/dev/null",
3204 filter_has_file = 0;
3205 if (filter_child_proc) {
3206 SvREFCNT_dec(filter_child_proc);
3207 filter_child_proc = 0;
3210 SvREFCNT_dec(filter_state);
3214 SvREFCNT_dec(filter_sub);
3219 char *dir = SvPVx(dirsv, n_a);
3220 #ifdef MACOS_TRADITIONAL
3222 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3226 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3228 sv_setpv(namesv, unixdir);
3229 sv_catpv(namesv, unixname);
3231 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3234 TAINT_PROPER("require");
3235 tryname = SvPVX(namesv);
3236 #ifdef MACOS_TRADITIONAL
3238 /* Convert slashes in the name part, but not the directory part, to colons */
3240 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3244 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3246 if (tryname[0] == '.' && tryname[1] == '/')
3254 SAVECOPFILE_FREE(&PL_compiling);
3255 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3256 SvREFCNT_dec(namesv);
3258 if (PL_op->op_type == OP_REQUIRE) {
3259 char *msgstr = name;
3260 if (namesv) { /* did we lookup @INC? */
3261 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3262 SV *dirmsgsv = NEWSV(0, 0);
3263 AV *ar = GvAVn(PL_incgv);
3265 sv_catpvn(msg, " in @INC", 8);
3266 if (instr(SvPVX(msg), ".h "))
3267 sv_catpv(msg, " (change .h to .ph maybe?)");
3268 if (instr(SvPVX(msg), ".ph "))
3269 sv_catpv(msg, " (did you run h2ph?)");
3270 sv_catpv(msg, " (@INC contains:");
3271 for (i = 0; i <= AvFILL(ar); i++) {
3272 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3273 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3274 sv_catsv(msg, dirmsgsv);
3276 sv_catpvn(msg, ")", 1);
3277 SvREFCNT_dec(dirmsgsv);
3278 msgstr = SvPV_nolen(msg);
3280 DIE(aTHX_ "Can't locate %s", msgstr);
3286 SETERRNO(0, SS$_NORMAL);
3288 /* Assume success here to prevent recursive requirement. */
3289 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3290 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3294 lex_start(sv_2mortal(newSVpvn("",0)));
3295 SAVEGENERICSV(PL_rsfp_filters);
3296 PL_rsfp_filters = Nullav;
3301 SAVESPTR(PL_compiling.cop_warnings);
3302 if (PL_dowarn & G_WARN_ALL_ON)
3303 PL_compiling.cop_warnings = pWARN_ALL ;
3304 else if (PL_dowarn & G_WARN_ALL_OFF)
3305 PL_compiling.cop_warnings = pWARN_NONE ;
3307 PL_compiling.cop_warnings = pWARN_STD ;
3308 SAVESPTR(PL_compiling.cop_io);
3309 PL_compiling.cop_io = Nullsv;
3311 if (filter_sub || filter_child_proc) {
3312 SV *datasv = filter_add(run_user_filter, Nullsv);
3313 IoLINES(datasv) = filter_has_file;
3314 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3315 IoTOP_GV(datasv) = (GV *)filter_state;
3316 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3319 /* switch to eval mode */
3320 push_return(PL_op->op_next);
3321 PUSHBLOCK(cx, CXt_EVAL, SP);
3322 PUSHEVAL(cx, name, Nullgv);
3324 SAVECOPLINE(&PL_compiling);
3325 CopLINE_set(&PL_compiling, 0);
3329 MUTEX_LOCK(&PL_eval_mutex);
3330 if (PL_eval_owner && PL_eval_owner != thr)
3331 while (PL_eval_owner)
3332 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3333 PL_eval_owner = thr;
3334 MUTEX_UNLOCK(&PL_eval_mutex);
3335 #endif /* USE_THREADS */
3336 return DOCATCH(doeval(G_SCALAR, NULL));
3341 return pp_require();
3347 register PERL_CONTEXT *cx;
3349 I32 gimme = GIMME_V, was = PL_sub_generation;
3350 char tbuf[TYPE_DIGITS(long) + 12];
3351 char *tmpbuf = tbuf;
3356 if (!SvPV(sv,len) || !len)
3358 TAINT_PROPER("eval");
3364 /* switch to eval mode */
3366 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3367 SV *sv = sv_newmortal();
3368 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3369 (unsigned long)++PL_evalseq,
3370 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3374 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3375 SAVECOPFILE_FREE(&PL_compiling);
3376 CopFILE_set(&PL_compiling, tmpbuf+2);
3377 SAVECOPLINE(&PL_compiling);
3378 CopLINE_set(&PL_compiling, 1);
3379 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3380 deleting the eval's FILEGV from the stash before gv_check() runs
3381 (i.e. before run-time proper). To work around the coredump that
3382 ensues, we always turn GvMULTI_on for any globals that were
3383 introduced within evals. See force_ident(). GSAR 96-10-12 */
3384 safestr = savepv(tmpbuf);
3385 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3387 PL_hints = PL_op->op_targ;
3388 SAVESPTR(PL_compiling.cop_warnings);
3389 if (specialWARN(PL_curcop->cop_warnings))
3390 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3392 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3393 SAVEFREESV(PL_compiling.cop_warnings);
3395 SAVESPTR(PL_compiling.cop_io);
3396 if (specialCopIO(PL_curcop->cop_io))
3397 PL_compiling.cop_io = PL_curcop->cop_io;
3399 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3400 SAVEFREESV(PL_compiling.cop_io);
3403 push_return(PL_op->op_next);
3404 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3405 PUSHEVAL(cx, 0, Nullgv);
3407 /* prepare to compile string */
3409 if (PERLDB_LINE && PL_curstash != PL_debstash)
3410 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3413 MUTEX_LOCK(&PL_eval_mutex);
3414 if (PL_eval_owner && PL_eval_owner != thr)
3415 while (PL_eval_owner)
3416 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3417 PL_eval_owner = thr;
3418 MUTEX_UNLOCK(&PL_eval_mutex);
3419 #endif /* USE_THREADS */
3420 ret = doeval(gimme, NULL);
3421 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3422 && ret != PL_op->op_next) { /* Successive compilation. */
3423 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3425 return DOCATCH(ret);
3435 register PERL_CONTEXT *cx;
3437 U8 save_flags = PL_op -> op_flags;
3442 retop = pop_return();
3445 if (gimme == G_VOID)
3447 else if (gimme == G_SCALAR) {
3450 if (SvFLAGS(TOPs) & SVs_TEMP)
3453 *MARK = sv_mortalcopy(TOPs);
3457 *MARK = &PL_sv_undef;
3462 /* in case LEAVE wipes old return values */
3463 for (mark = newsp + 1; mark <= SP; mark++) {
3464 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3465 *mark = sv_mortalcopy(*mark);
3466 TAINT_NOT; /* Each item is independent */
3470 PL_curpm = newpm; /* Don't pop $1 et al till now */
3472 if (AvFILLp(PL_comppad_name) >= 0)
3476 assert(CvDEPTH(PL_compcv) == 1);
3478 CvDEPTH(PL_compcv) = 0;
3481 if (optype == OP_REQUIRE &&
3482 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3484 /* Unassume the success we assumed earlier. */
3485 SV *nsv = cx->blk_eval.old_namesv;
3486 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3487 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3488 /* die_where() did LEAVE, or we won't be here */
3492 if (!(save_flags & OPf_SPECIAL))
3502 register PERL_CONTEXT *cx;
3503 I32 gimme = GIMME_V;
3508 push_return(cLOGOP->op_other->op_next);
3509 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3511 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3513 PL_in_eval = EVAL_INEVAL;
3516 return DOCATCH(PL_op->op_next);
3526 register PERL_CONTEXT *cx;
3534 if (gimme == G_VOID)
3536 else if (gimme == G_SCALAR) {
3539 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3542 *MARK = sv_mortalcopy(TOPs);
3546 *MARK = &PL_sv_undef;
3551 /* in case LEAVE wipes old return values */
3552 for (mark = newsp + 1; mark <= SP; mark++) {
3553 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3554 *mark = sv_mortalcopy(*mark);
3555 TAINT_NOT; /* Each item is independent */
3559 PL_curpm = newpm; /* Don't pop $1 et al till now */
3567 S_doparseform(pTHX_ SV *sv)
3570 register char *s = SvPV_force(sv, len);
3571 register char *send = s + len;
3572 register char *base;
3573 register I32 skipspaces = 0;
3576 bool postspace = FALSE;
3584 Perl_croak(aTHX_ "Null picture in formline");
3586 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3591 *fpc++ = FF_LINEMARK;
3592 noblank = repeat = FALSE;
3610 case ' ': case '\t':
3621 *fpc++ = FF_LITERAL;
3629 *fpc++ = skipspaces;
3633 *fpc++ = FF_NEWLINE;
3637 arg = fpc - linepc + 1;
3644 *fpc++ = FF_LINEMARK;
3645 noblank = repeat = FALSE;
3654 ischop = s[-1] == '^';
3660 arg = (s - base) - 1;
3662 *fpc++ = FF_LITERAL;
3671 *fpc++ = FF_LINEGLOB;
3673 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3674 arg = ischop ? 512 : 0;
3684 arg |= 256 + (s - f);
3686 *fpc++ = s - base; /* fieldsize for FETCH */
3687 *fpc++ = FF_DECIMAL;
3690 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3691 arg = ischop ? 512 : 0;
3693 s++; /* skip the '0' first */
3702 arg |= 256 + (s - f);
3704 *fpc++ = s - base; /* fieldsize for FETCH */
3705 *fpc++ = FF_0DECIMAL;
3710 bool ismore = FALSE;
3713 while (*++s == '>') ;
3714 prespace = FF_SPACE;
3716 else if (*s == '|') {
3717 while (*++s == '|') ;
3718 prespace = FF_HALFSPACE;
3723 while (*++s == '<') ;
3726 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3730 *fpc++ = s - base; /* fieldsize for FETCH */
3732 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3750 { /* need to jump to the next word */
3752 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3753 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3754 s = SvPVX(sv) + SvCUR(sv) + z;
3756 Copy(fops, s, arg, U16);
3758 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3763 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3765 * The original code was written in conjunction with BSD Computer Software
3766 * Research Group at University of California, Berkeley.
3768 * See also: "Optimistic Merge Sort" (SODA '92)
3770 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3772 * The code can be distributed under the same terms as Perl itself.
3777 #include <sys/types.h>
3782 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3783 #define Safefree(VAR) free(VAR)
3784 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3785 #endif /* TESTHARNESS */
3787 typedef char * aptr; /* pointer for arithmetic on sizes */
3788 typedef SV * gptr; /* pointers in our lists */
3790 /* Binary merge internal sort, with a few special mods
3791 ** for the special perl environment it now finds itself in.
3793 ** Things that were once options have been hotwired
3794 ** to values suitable for this use. In particular, we'll always
3795 ** initialize looking for natural runs, we'll always produce stable
3796 ** output, and we'll always do Peter McIlroy's binary merge.
3799 /* Pointer types for arithmetic and storage and convenience casts */
3801 #define APTR(P) ((aptr)(P))
3802 #define GPTP(P) ((gptr *)(P))
3803 #define GPPP(P) ((gptr **)(P))
3806 /* byte offset from pointer P to (larger) pointer Q */
3807 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3809 #define PSIZE sizeof(gptr)
3811 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3814 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3815 #define PNBYTE(N) ((N) << (PSHIFT))
3816 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3818 /* Leave optimization to compiler */
3819 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3820 #define PNBYTE(N) ((N) * (PSIZE))
3821 #define PINDEX(P, N) (GPTP(P) + (N))
3824 /* Pointer into other corresponding to pointer into this */
3825 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3827 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3830 /* Runs are identified by a pointer in the auxilliary list.
3831 ** The pointer is at the start of the list,
3832 ** and it points to the start of the next list.
3833 ** NEXT is used as an lvalue, too.
3836 #define NEXT(P) (*GPPP(P))
3839 /* PTHRESH is the minimum number of pairs with the same sense to justify
3840 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3841 ** not just elements, so PTHRESH == 8 means a run of 16.
3846 /* RTHRESH is the number of elements in a run that must compare low
3847 ** to the low element from the opposing run before we justify
3848 ** doing a binary rampup instead of single stepping.
3849 ** In random input, N in a row low should only happen with
3850 ** probability 2^(1-N), so we can risk that we are dealing
3851 ** with orderly input without paying much when we aren't.
3858 ** Overview of algorithm and variables.
3859 ** The array of elements at list1 will be organized into runs of length 2,
3860 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3861 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3863 ** Unless otherwise specified, pair pointers address the first of two elements.
3865 ** b and b+1 are a pair that compare with sense ``sense''.
3866 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3868 ** p2 parallels b in the list2 array, where runs are defined by
3871 ** t represents the ``top'' of the adjacent pairs that might extend
3872 ** the run beginning at b. Usually, t addresses a pair
3873 ** that compares with opposite sense from (b,b+1).
3874 ** However, it may also address a singleton element at the end of list1,
3875 ** or it may be equal to ``last'', the first element beyond list1.
3877 ** r addresses the Nth pair following b. If this would be beyond t,
3878 ** we back it off to t. Only when r is less than t do we consider the
3879 ** run long enough to consider checking.
3881 ** q addresses a pair such that the pairs at b through q already form a run.
3882 ** Often, q will equal b, indicating we only are sure of the pair itself.
3883 ** However, a search on the previous cycle may have revealed a longer run,
3884 ** so q may be greater than b.
3886 ** p is used to work back from a candidate r, trying to reach q,
3887 ** which would mean b through r would be a run. If we discover such a run,
3888 ** we start q at r and try to push it further towards t.
3889 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3890 ** In any event, after the check (if any), we have two main cases.
3892 ** 1) Short run. b <= q < p <= r <= t.
3893 ** b through q is a run (perhaps trivial)
3894 ** q through p are uninteresting pairs
3895 ** p through r is a run
3897 ** 2) Long run. b < r <= q < t.
3898 ** b through q is a run (of length >= 2 * PTHRESH)
3900 ** Note that degenerate cases are not only possible, but likely.
3901 ** For example, if the pair following b compares with opposite sense,
3902 ** then b == q < p == r == t.
3907 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3910 register gptr *b, *p, *q, *t, *p2;
3911 register gptr c, *last, *r;
3915 last = PINDEX(b, nmemb);
3916 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3917 for (p2 = list2; b < last; ) {
3918 /* We just started, or just reversed sense.
3919 ** Set t at end of pairs with the prevailing sense.
3921 for (p = b+2, t = p; ++p < last; t = ++p) {
3922 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3925 /* Having laid out the playing field, look for long runs */
3927 p = r = b + (2 * PTHRESH);
3928 if (r >= t) p = r = t; /* too short to care about */
3930 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3933 /* b through r is a (long) run.
3934 ** Extend it as far as possible.
3937 while (((p += 2) < t) &&
3938 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3939 r = p = q + 2; /* no simple pairs, no after-run */
3942 if (q > b) { /* run of greater than 2 at b */
3945 /* pick up singleton, if possible */
3947 ((t + 1) == last) &&
3948 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3949 savep = r = p = q = last;
3950 p2 = NEXT(p2) = p2 + (p - b);
3951 if (sense) while (b < --p) {
3958 while (q < p) { /* simple pairs */
3959 p2 = NEXT(p2) = p2 + 2;
3966 if (((b = p) == t) && ((t+1) == last)) {
3978 /* Overview of bmerge variables:
3980 ** list1 and list2 address the main and auxiliary arrays.
3981 ** They swap identities after each merge pass.
3982 ** Base points to the original list1, so we can tell if
3983 ** the pointers ended up where they belonged (or must be copied).
3985 ** When we are merging two lists, f1 and f2 are the next elements
3986 ** on the respective lists. l1 and l2 mark the end of the lists.
3987 ** tp2 is the current location in the merged list.
3989 ** p1 records where f1 started.
3990 ** After the merge, a new descriptor is built there.
3992 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3993 ** It is used to identify and delimit the runs.
3995 ** In the heat of determining where q, the greater of the f1/f2 elements,
3996 ** belongs in the other list, b, t and p, represent bottom, top and probe
3997 ** locations, respectively, in the other list.
3998 ** They make convenient temporary pointers in other places.
4002 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4006 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4007 gptr *aux, *list2, *p2, *last;
4011 if (nmemb <= 1) return; /* sorted trivially */
4012 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4014 dynprep(aTHX_ list1, list2, nmemb, cmp);
4015 last = PINDEX(list2, nmemb);
4016 while (NEXT(list2) != last) {
4017 /* More than one run remains. Do some merging to reduce runs. */
4019 for (tp2 = p2 = list2; p2 != last;) {
4020 /* The new first run begins where the old second list ended.
4021 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4025 f2 = l1 = POTHER(t, list2, list1);
4026 if (t != last) t = NEXT(t);
4027 l2 = POTHER(t, list2, list1);
4029 while (f1 < l1 && f2 < l2) {
4030 /* If head 1 is larger than head 2, find ALL the elements
4031 ** in list 2 strictly less than head1, write them all,
4032 ** then head 1. Then compare the new heads, and repeat,
4033 ** until one or both lists are exhausted.
4035 ** In all comparisons (after establishing
4036 ** which head to merge) the item to merge
4037 ** (at pointer q) is the first operand of
4038 ** the comparison. When we want to know
4039 ** if ``q is strictly less than the other'',
4041 ** cmp(q, other) < 0
4042 ** because stability demands that we treat equality
4043 ** as high when q comes from l2, and as low when
4044 ** q was from l1. So we ask the question by doing
4045 ** cmp(q, other) <= sense
4046 ** and make sense == 0 when equality should look low,
4047 ** and -1 when equality should look high.
4051 if (cmp(aTHX_ *f1, *f2) <= 0) {
4052 q = f2; b = f1; t = l1;
4055 q = f1; b = f2; t = l2;
4062 ** Leave t at something strictly
4063 ** greater than q (or at the end of the list),
4064 ** and b at something strictly less than q.
4066 for (i = 1, run = 0 ;;) {
4067 if ((p = PINDEX(b, i)) >= t) {
4069 if (((p = PINDEX(t, -1)) > b) &&
4070 (cmp(aTHX_ *q, *p) <= sense))
4074 } else if (cmp(aTHX_ *q, *p) <= sense) {
4078 if (++run >= RTHRESH) i += i;
4082 /* q is known to follow b and must be inserted before t.
4083 ** Increment b, so the range of possibilities is [b,t).
4084 ** Round binary split down, to favor early appearance.
4085 ** Adjust b and t until q belongs just before t.
4090 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4091 if (cmp(aTHX_ *q, *p) <= sense) {
4097 /* Copy all the strictly low elements */
4100 FROMTOUPTO(f2, tp2, t);
4103 FROMTOUPTO(f1, tp2, t);
4109 /* Run out remaining list */
4111 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4112 } else FROMTOUPTO(f1, tp2, l1);
4113 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4118 last = PINDEX(list2, nmemb);
4120 if (base == list2) {
4121 last = PINDEX(list1, nmemb);
4122 FROMTOUPTO(list1, list2, last);
4137 sortcv(pTHXo_ SV *a, SV *b)
4139 I32 oldsaveix = PL_savestack_ix;
4140 I32 oldscopeix = PL_scopestack_ix;
4142 GvSV(PL_firstgv) = a;
4143 GvSV(PL_secondgv) = b;
4144 PL_stack_sp = PL_stack_base;
4147 if (PL_stack_sp != PL_stack_base + 1)
4148 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4149 if (!SvNIOKp(*PL_stack_sp))
4150 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4151 result = SvIV(*PL_stack_sp);
4152 while (PL_scopestack_ix > oldscopeix) {
4155 leave_scope(oldsaveix);
4160 sortcv_stacked(pTHXo_ SV *a, SV *b)
4162 I32 oldsaveix = PL_savestack_ix;
4163 I32 oldscopeix = PL_scopestack_ix;
4168 av = (AV*)PL_curpad[0];
4170 av = GvAV(PL_defgv);
4173 if (AvMAX(av) < 1) {
4174 SV** ary = AvALLOC(av);
4175 if (AvARRAY(av) != ary) {
4176 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4177 SvPVX(av) = (char*)ary;
4179 if (AvMAX(av) < 1) {
4182 SvPVX(av) = (char*)ary;
4189 PL_stack_sp = PL_stack_base;
4192 if (PL_stack_sp != PL_stack_base + 1)
4193 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4194 if (!SvNIOKp(*PL_stack_sp))
4195 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4196 result = SvIV(*PL_stack_sp);
4197 while (PL_scopestack_ix > oldscopeix) {
4200 leave_scope(oldsaveix);
4205 sortcv_xsub(pTHXo_ SV *a, SV *b)
4208 I32 oldsaveix = PL_savestack_ix;
4209 I32 oldscopeix = PL_scopestack_ix;
4211 CV *cv=(CV*)PL_sortcop;
4219 (void)(*CvXSUB(cv))(aTHXo_ cv);
4220 if (PL_stack_sp != PL_stack_base + 1)
4221 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4222 if (!SvNIOKp(*PL_stack_sp))
4223 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4224 result = SvIV(*PL_stack_sp);
4225 while (PL_scopestack_ix > oldscopeix) {
4228 leave_scope(oldsaveix);
4234 sv_ncmp(pTHXo_ SV *a, SV *b)
4238 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4242 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4246 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4248 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4250 if (PL_amagic_generation) { \
4251 if (SvAMAGIC(left)||SvAMAGIC(right))\
4252 *svp = amagic_call(left, \
4260 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4263 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4268 I32 i = SvIVX(tmpsv);
4278 return sv_ncmp(aTHXo_ a, b);
4282 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4285 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4290 I32 i = SvIVX(tmpsv);
4300 return sv_i_ncmp(aTHXo_ a, b);
4304 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4307 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4312 I32 i = SvIVX(tmpsv);
4322 return sv_cmp(str1, str2);
4326 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4329 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4334 I32 i = SvIVX(tmpsv);
4344 return sv_cmp_locale(str1, str2);
4348 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4350 SV *datasv = FILTER_DATA(idx);
4351 int filter_has_file = IoLINES(datasv);
4352 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4353 SV *filter_state = (SV *)IoTOP_GV(datasv);
4354 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4357 /* I was having segfault trouble under Linux 2.2.5 after a
4358 parse error occured. (Had to hack around it with a test
4359 for PL_error_count == 0.) Solaris doesn't segfault --
4360 not sure where the trouble is yet. XXX */
4362 if (filter_has_file) {
4363 len = FILTER_READ(idx+1, buf_sv, maxlen);
4366 if (filter_sub && len >= 0) {
4377 PUSHs(sv_2mortal(newSViv(maxlen)));
4379 PUSHs(filter_state);
4382 count = call_sv(filter_sub, G_SCALAR);
4398 IoLINES(datasv) = 0;
4399 if (filter_child_proc) {
4400 SvREFCNT_dec(filter_child_proc);
4401 IoFMT_GV(datasv) = Nullgv;
4404 SvREFCNT_dec(filter_state);
4405 IoTOP_GV(datasv) = Nullgv;
4408 SvREFCNT_dec(filter_sub);
4409 IoBOTTOM_GV(datasv) = Nullgv;
4411 filter_del(run_user_filter);
4420 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4422 return sv_cmp_locale(str1, str2);
4426 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4428 return sv_cmp(str1, str2);
4431 #endif /* PERL_OBJECT */