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 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1782 iterdata = (void*)PL_op->op_targ;
1783 cxtype |= CXp_PADVAR;
1788 svp = &GvSV(gv); /* symbol table variable */
1789 SAVEGENERICSV(*svp);
1792 iterdata = (void*)gv;
1798 PUSHBLOCK(cx, cxtype, SP);
1800 PUSHLOOP(cx, iterdata, MARK);
1802 PUSHLOOP(cx, svp, MARK);
1804 if (PL_op->op_flags & OPf_STACKED) {
1805 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1806 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1808 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1809 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1810 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1811 looks_like_number((SV*)cx->blk_loop.iterary) &&
1812 *SvPVX(cx->blk_loop.iterary) != '0'))
1814 if (SvNV(sv) < IV_MIN ||
1815 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1816 DIE(aTHX_ "Range iterator outside integer range");
1817 cx->blk_loop.iterix = SvIV(sv);
1818 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1821 cx->blk_loop.iterlval = newSVsv(sv);
1825 cx->blk_loop.iterary = PL_curstack;
1826 AvFILLp(PL_curstack) = SP - PL_stack_base;
1827 cx->blk_loop.iterix = MARK - PL_stack_base;
1836 register PERL_CONTEXT *cx;
1837 I32 gimme = GIMME_V;
1843 PUSHBLOCK(cx, CXt_LOOP, SP);
1844 PUSHLOOP(cx, 0, SP);
1852 register PERL_CONTEXT *cx;
1860 newsp = PL_stack_base + cx->blk_loop.resetsp;
1863 if (gimme == G_VOID)
1865 else if (gimme == G_SCALAR) {
1867 *++newsp = sv_mortalcopy(*SP);
1869 *++newsp = &PL_sv_undef;
1873 *++newsp = sv_mortalcopy(*++mark);
1874 TAINT_NOT; /* Each item is independent */
1880 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1881 PL_curpm = newpm; /* ... and pop $1 et al */
1893 register PERL_CONTEXT *cx;
1894 bool popsub2 = FALSE;
1895 bool clear_errsv = FALSE;
1902 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1903 if (cxstack_ix == PL_sortcxix
1904 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1906 if (cxstack_ix > PL_sortcxix)
1907 dounwind(PL_sortcxix);
1908 AvARRAY(PL_curstack)[1] = *SP;
1909 PL_stack_sp = PL_stack_base + 1;
1914 cxix = dopoptosub(cxstack_ix);
1916 DIE(aTHX_ "Can't return outside a subroutine");
1917 if (cxix < cxstack_ix)
1921 switch (CxTYPE(cx)) {
1926 if (!(PL_in_eval & EVAL_KEEPERR))
1931 if (AvFILLp(PL_comppad_name) >= 0)
1934 if (optype == OP_REQUIRE &&
1935 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1937 /* Unassume the success we assumed earlier. */
1938 SV *nsv = cx->blk_eval.old_namesv;
1939 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1940 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1947 DIE(aTHX_ "panic: return");
1951 if (gimme == G_SCALAR) {
1954 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1956 *++newsp = SvREFCNT_inc(*SP);
1961 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1963 *++newsp = sv_mortalcopy(sv);
1968 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1971 *++newsp = sv_mortalcopy(*SP);
1974 *++newsp = &PL_sv_undef;
1976 else if (gimme == G_ARRAY) {
1977 while (++MARK <= SP) {
1978 *++newsp = (popsub2 && SvTEMP(*MARK))
1979 ? *MARK : sv_mortalcopy(*MARK);
1980 TAINT_NOT; /* Each item is independent */
1983 PL_stack_sp = newsp;
1985 /* Stack values are safe: */
1987 POPSUB(cx,sv); /* release CV and @_ ... */
1991 PL_curpm = newpm; /* ... and pop $1 et al */
1997 return pop_return();
2004 register PERL_CONTEXT *cx;
2014 if (PL_op->op_flags & OPf_SPECIAL) {
2015 cxix = dopoptoloop(cxstack_ix);
2017 DIE(aTHX_ "Can't \"last\" outside a loop block");
2020 cxix = dopoptolabel(cPVOP->op_pv);
2022 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2024 if (cxix < cxstack_ix)
2029 switch (CxTYPE(cx)) {
2032 newsp = PL_stack_base + cx->blk_loop.resetsp;
2033 nextop = cx->blk_loop.last_op->op_next;
2037 nextop = pop_return();
2041 nextop = pop_return();
2045 nextop = pop_return();
2048 DIE(aTHX_ "panic: last");
2052 if (gimme == G_SCALAR) {
2054 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2055 ? *SP : sv_mortalcopy(*SP);
2057 *++newsp = &PL_sv_undef;
2059 else if (gimme == G_ARRAY) {
2060 while (++MARK <= SP) {
2061 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2062 ? *MARK : sv_mortalcopy(*MARK);
2063 TAINT_NOT; /* Each item is independent */
2069 /* Stack values are safe: */
2072 POPLOOP(cx); /* release loop vars ... */
2076 POPSUB(cx,sv); /* release CV and @_ ... */
2079 PL_curpm = newpm; /* ... and pop $1 et al */
2089 register PERL_CONTEXT *cx;
2092 if (PL_op->op_flags & OPf_SPECIAL) {
2093 cxix = dopoptoloop(cxstack_ix);
2095 DIE(aTHX_ "Can't \"next\" outside a loop block");
2098 cxix = dopoptolabel(cPVOP->op_pv);
2100 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2102 if (cxix < cxstack_ix)
2105 /* clear off anything above the scope we're re-entering, but
2106 * save the rest until after a possible continue block */
2107 inner = PL_scopestack_ix;
2109 if (PL_scopestack_ix < inner)
2110 leave_scope(PL_scopestack[PL_scopestack_ix]);
2111 return cx->blk_loop.next_op;
2117 register PERL_CONTEXT *cx;
2120 if (PL_op->op_flags & OPf_SPECIAL) {
2121 cxix = dopoptoloop(cxstack_ix);
2123 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2126 cxix = dopoptolabel(cPVOP->op_pv);
2128 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2130 if (cxix < cxstack_ix)
2134 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2135 LEAVE_SCOPE(oldsave);
2136 return cx->blk_loop.redo_op;
2140 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2144 static char too_deep[] = "Target of goto is too deeply nested";
2147 Perl_croak(aTHX_ too_deep);
2148 if (o->op_type == OP_LEAVE ||
2149 o->op_type == OP_SCOPE ||
2150 o->op_type == OP_LEAVELOOP ||
2151 o->op_type == OP_LEAVETRY)
2153 *ops++ = cUNOPo->op_first;
2155 Perl_croak(aTHX_ too_deep);
2158 if (o->op_flags & OPf_KIDS) {
2160 /* First try all the kids at this level, since that's likeliest. */
2161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2162 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2163 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2166 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2167 if (kid == PL_lastgotoprobe)
2169 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2171 (ops[-1]->op_type != OP_NEXTSTATE &&
2172 ops[-1]->op_type != OP_DBSTATE)))
2174 if ((o = dofindlabel(kid, label, ops, oplimit)))
2193 register PERL_CONTEXT *cx;
2194 #define GOTO_DEPTH 64
2195 OP *enterops[GOTO_DEPTH];
2197 int do_dump = (PL_op->op_type == OP_DUMP);
2198 static char must_have_label[] = "goto must have label";
2201 if (PL_op->op_flags & OPf_STACKED) {
2205 /* This egregious kludge implements goto &subroutine */
2206 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2208 register PERL_CONTEXT *cx;
2209 CV* cv = (CV*)SvRV(sv);
2215 if (!CvROOT(cv) && !CvXSUB(cv)) {
2220 /* autoloaded stub? */
2221 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2223 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2224 GvNAMELEN(gv), FALSE);
2225 if (autogv && (cv = GvCV(autogv)))
2227 tmpstr = sv_newmortal();
2228 gv_efullname3(tmpstr, gv, Nullch);
2229 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2231 DIE(aTHX_ "Goto undefined subroutine");
2234 /* First do some returnish stuff. */
2235 cxix = dopoptosub(cxstack_ix);
2237 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2238 if (cxix < cxstack_ix)
2241 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2242 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2244 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2245 /* put @_ back onto stack */
2246 AV* av = cx->blk_sub.argarray;
2248 items = AvFILLp(av) + 1;
2250 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2251 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2252 PL_stack_sp += items;
2254 SvREFCNT_dec(GvAV(PL_defgv));
2255 GvAV(PL_defgv) = cx->blk_sub.savearray;
2256 #endif /* USE_THREADS */
2257 /* abandon @_ if it got reified */
2259 (void)sv_2mortal((SV*)av); /* delay until return */
2261 av_extend(av, items-1);
2262 AvFLAGS(av) = AVf_REIFY;
2263 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2266 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2269 av = (AV*)PL_curpad[0];
2271 av = GvAV(PL_defgv);
2273 items = AvFILLp(av) + 1;
2275 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2276 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2277 PL_stack_sp += items;
2279 if (CxTYPE(cx) == CXt_SUB &&
2280 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2281 SvREFCNT_dec(cx->blk_sub.cv);
2282 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2283 LEAVE_SCOPE(oldsave);
2285 /* Now do some callish stuff. */
2288 #ifdef PERL_XSUB_OLDSTYLE
2289 if (CvOLDSTYLE(cv)) {
2290 I32 (*fp3)(int,int,int);
2295 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2296 items = (*fp3)(CvXSUBANY(cv).any_i32,
2297 mark - PL_stack_base + 1,
2299 SP = PL_stack_base + items;
2302 #endif /* PERL_XSUB_OLDSTYLE */
2307 PL_stack_sp--; /* There is no cv arg. */
2308 /* Push a mark for the start of arglist */
2310 (void)(*CvXSUB(cv))(aTHXo_ cv);
2311 /* Pop the current context like a decent sub should */
2312 POPBLOCK(cx, PL_curpm);
2313 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2316 return pop_return();
2319 AV* padlist = CvPADLIST(cv);
2320 SV** svp = AvARRAY(padlist);
2321 if (CxTYPE(cx) == CXt_EVAL) {
2322 PL_in_eval = cx->blk_eval.old_in_eval;
2323 PL_eval_root = cx->blk_eval.old_eval_root;
2324 cx->cx_type = CXt_SUB;
2325 cx->blk_sub.hasargs = 0;
2327 cx->blk_sub.cv = cv;
2328 cx->blk_sub.olddepth = CvDEPTH(cv);
2330 if (CvDEPTH(cv) < 2)
2331 (void)SvREFCNT_inc(cv);
2332 else { /* save temporaries on recursion? */
2333 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2334 sub_crush_depth(cv);
2335 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2336 AV *newpad = newAV();
2337 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2338 I32 ix = AvFILLp((AV*)svp[1]);
2339 I32 names_fill = AvFILLp((AV*)svp[0]);
2340 svp = AvARRAY(svp[0]);
2341 for ( ;ix > 0; ix--) {
2342 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2343 char *name = SvPVX(svp[ix]);
2344 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2347 /* outer lexical or anon code */
2348 av_store(newpad, ix,
2349 SvREFCNT_inc(oldpad[ix]) );
2351 else { /* our own lexical */
2353 av_store(newpad, ix, sv = (SV*)newAV());
2354 else if (*name == '%')
2355 av_store(newpad, ix, sv = (SV*)newHV());
2357 av_store(newpad, ix, sv = NEWSV(0,0));
2361 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2362 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2365 av_store(newpad, ix, sv = NEWSV(0,0));
2369 if (cx->blk_sub.hasargs) {
2372 av_store(newpad, 0, (SV*)av);
2373 AvFLAGS(av) = AVf_REIFY;
2375 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2376 AvFILLp(padlist) = CvDEPTH(cv);
2377 svp = AvARRAY(padlist);
2381 if (!cx->blk_sub.hasargs) {
2382 AV* av = (AV*)PL_curpad[0];
2384 items = AvFILLp(av) + 1;
2386 /* Mark is at the end of the stack. */
2388 Copy(AvARRAY(av), SP + 1, items, SV*);
2393 #endif /* USE_THREADS */
2394 SAVEVPTR(PL_curpad);
2395 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2397 if (cx->blk_sub.hasargs)
2398 #endif /* USE_THREADS */
2400 AV* av = (AV*)PL_curpad[0];
2404 cx->blk_sub.savearray = GvAV(PL_defgv);
2405 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2406 #endif /* USE_THREADS */
2407 cx->blk_sub.oldcurpad = PL_curpad;
2408 cx->blk_sub.argarray = av;
2411 if (items >= AvMAX(av) + 1) {
2413 if (AvARRAY(av) != ary) {
2414 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2415 SvPVX(av) = (char*)ary;
2417 if (items >= AvMAX(av) + 1) {
2418 AvMAX(av) = items - 1;
2419 Renew(ary,items+1,SV*);
2421 SvPVX(av) = (char*)ary;
2424 Copy(mark,AvARRAY(av),items,SV*);
2425 AvFILLp(av) = items - 1;
2426 assert(!AvREAL(av));
2433 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2435 * We do not care about using sv to call CV;
2436 * it's for informational purposes only.
2438 SV *sv = GvSV(PL_DBsub);
2441 if (PERLDB_SUB_NN) {
2442 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2445 gv_efullname3(sv, CvGV(cv), Nullch);
2448 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2449 PUSHMARK( PL_stack_sp );
2450 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2454 RETURNOP(CvSTART(cv));
2458 label = SvPV(sv,n_a);
2459 if (!(do_dump || *label))
2460 DIE(aTHX_ must_have_label);
2463 else if (PL_op->op_flags & OPf_SPECIAL) {
2465 DIE(aTHX_ must_have_label);
2468 label = cPVOP->op_pv;
2470 if (label && *label) {
2475 PL_lastgotoprobe = 0;
2477 for (ix = cxstack_ix; ix >= 0; ix--) {
2479 switch (CxTYPE(cx)) {
2481 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2484 gotoprobe = cx->blk_oldcop->op_sibling;
2490 gotoprobe = cx->blk_oldcop->op_sibling;
2492 gotoprobe = PL_main_root;
2495 if (CvDEPTH(cx->blk_sub.cv)) {
2496 gotoprobe = CvROOT(cx->blk_sub.cv);
2502 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2505 DIE(aTHX_ "panic: goto");
2506 gotoprobe = PL_main_root;
2510 retop = dofindlabel(gotoprobe, label,
2511 enterops, enterops + GOTO_DEPTH);
2515 PL_lastgotoprobe = gotoprobe;
2518 DIE(aTHX_ "Can't find label %s", label);
2520 /* pop unwanted frames */
2522 if (ix < cxstack_ix) {
2529 oldsave = PL_scopestack[PL_scopestack_ix];
2530 LEAVE_SCOPE(oldsave);
2533 /* push wanted frames */
2535 if (*enterops && enterops[1]) {
2537 for (ix = 1; enterops[ix]; ix++) {
2538 PL_op = enterops[ix];
2539 /* Eventually we may want to stack the needed arguments
2540 * for each op. For now, we punt on the hard ones. */
2541 if (PL_op->op_type == OP_ENTERITER)
2542 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2543 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2551 if (!retop) retop = PL_main_start;
2553 PL_restartop = retop;
2554 PL_do_undump = TRUE;
2558 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2559 PL_do_undump = FALSE;
2575 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2579 PL_exit_flags |= PERL_EXIT_EXPECTED;
2581 PUSHs(&PL_sv_undef);
2589 NV value = SvNVx(GvSV(cCOP->cop_gv));
2590 register I32 match = I_32(value);
2593 if (((NV)match) > value)
2594 --match; /* was fractional--truncate other way */
2596 match -= cCOP->uop.scop.scop_offset;
2599 else if (match > cCOP->uop.scop.scop_max)
2600 match = cCOP->uop.scop.scop_max;
2601 PL_op = cCOP->uop.scop.scop_next[match];
2611 PL_op = PL_op->op_next; /* can't assume anything */
2614 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2615 match -= cCOP->uop.scop.scop_offset;
2618 else if (match > cCOP->uop.scop.scop_max)
2619 match = cCOP->uop.scop.scop_max;
2620 PL_op = cCOP->uop.scop.scop_next[match];
2629 S_save_lines(pTHX_ AV *array, SV *sv)
2631 register char *s = SvPVX(sv);
2632 register char *send = SvPVX(sv) + SvCUR(sv);
2634 register I32 line = 1;
2636 while (s && s < send) {
2637 SV *tmpstr = NEWSV(85,0);
2639 sv_upgrade(tmpstr, SVt_PVMG);
2640 t = strchr(s, '\n');
2646 sv_setpvn(tmpstr, s, t - s);
2647 av_store(array, line++, tmpstr);
2652 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2654 S_docatch_body(pTHX_ va_list args)
2656 return docatch_body();
2661 S_docatch_body(pTHX)
2668 S_docatch(pTHX_ OP *o)
2673 volatile PERL_SI *cursi = PL_curstackinfo;
2677 assert(CATCH_GET == TRUE);
2680 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2682 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2688 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2694 if (PL_restartop && cursi == PL_curstackinfo) {
2695 PL_op = PL_restartop;
2712 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2713 /* sv Text to convert to OP tree. */
2714 /* startop op_free() this to undo. */
2715 /* code Short string id of the caller. */
2717 dSP; /* Make POPBLOCK work. */
2720 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2724 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2725 char *tmpbuf = tbuf;
2731 /* switch to eval mode */
2733 if (PL_curcop == &PL_compiling) {
2734 SAVECOPSTASH_FREE(&PL_compiling);
2735 CopSTASH_set(&PL_compiling, PL_curstash);
2737 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2738 SV *sv = sv_newmortal();
2739 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2740 code, (unsigned long)++PL_evalseq,
2741 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2745 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2746 SAVECOPFILE_FREE(&PL_compiling);
2747 CopFILE_set(&PL_compiling, tmpbuf+2);
2748 SAVECOPLINE(&PL_compiling);
2749 CopLINE_set(&PL_compiling, 1);
2750 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2751 deleting the eval's FILEGV from the stash before gv_check() runs
2752 (i.e. before run-time proper). To work around the coredump that
2753 ensues, we always turn GvMULTI_on for any globals that were
2754 introduced within evals. See force_ident(). GSAR 96-10-12 */
2755 safestr = savepv(tmpbuf);
2756 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2758 #ifdef OP_IN_REGISTER
2766 PL_op->op_type = OP_ENTEREVAL;
2767 PL_op->op_flags = 0; /* Avoid uninit warning. */
2768 PUSHBLOCK(cx, CXt_EVAL, SP);
2769 PUSHEVAL(cx, 0, Nullgv);
2770 rop = doeval(G_SCALAR, startop);
2771 POPBLOCK(cx,PL_curpm);
2774 (*startop)->op_type = OP_NULL;
2775 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2777 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2779 if (PL_curcop == &PL_compiling)
2780 PL_compiling.op_private = PL_hints;
2781 #ifdef OP_IN_REGISTER
2787 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2789 S_doeval(pTHX_ int gimme, OP** startop)
2797 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2798 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2803 /* set up a scratch pad */
2806 SAVEVPTR(PL_curpad);
2807 SAVESPTR(PL_comppad);
2808 SAVESPTR(PL_comppad_name);
2809 SAVEI32(PL_comppad_name_fill);
2810 SAVEI32(PL_min_intro_pending);
2811 SAVEI32(PL_max_intro_pending);
2814 for (i = cxstack_ix - 1; i >= 0; i--) {
2815 PERL_CONTEXT *cx = &cxstack[i];
2816 if (CxTYPE(cx) == CXt_EVAL)
2818 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2819 caller = cx->blk_sub.cv;
2824 SAVESPTR(PL_compcv);
2825 PL_compcv = (CV*)NEWSV(1104,0);
2826 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2827 CvEVAL_on(PL_compcv);
2829 CvOWNER(PL_compcv) = 0;
2830 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2831 MUTEX_INIT(CvMUTEXP(PL_compcv));
2832 #endif /* USE_THREADS */
2834 PL_comppad = newAV();
2835 av_push(PL_comppad, Nullsv);
2836 PL_curpad = AvARRAY(PL_comppad);
2837 PL_comppad_name = newAV();
2838 PL_comppad_name_fill = 0;
2839 PL_min_intro_pending = 0;
2842 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2843 PL_curpad[0] = (SV*)newAV();
2844 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2845 #endif /* USE_THREADS */
2847 comppadlist = newAV();
2848 AvREAL_off(comppadlist);
2849 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2850 av_store(comppadlist, 1, (SV*)PL_comppad);
2851 CvPADLIST(PL_compcv) = comppadlist;
2854 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2856 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2859 SAVEFREESV(PL_compcv);
2861 /* make sure we compile in the right package */
2863 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2864 SAVESPTR(PL_curstash);
2865 PL_curstash = CopSTASH(PL_curcop);
2867 SAVESPTR(PL_beginav);
2868 PL_beginav = newAV();
2869 SAVEFREESV(PL_beginav);
2870 SAVEI32(PL_error_count);
2872 /* try to compile it */
2874 PL_eval_root = Nullop;
2876 PL_curcop = &PL_compiling;
2877 PL_curcop->cop_arybase = 0;
2878 SvREFCNT_dec(PL_rs);
2879 PL_rs = newSVpvn("\n", 1);
2880 if (saveop && saveop->op_flags & OPf_SPECIAL)
2881 PL_in_eval |= EVAL_KEEPERR;
2884 if (yyparse() || PL_error_count || !PL_eval_root) {
2888 I32 optype = 0; /* Might be reset by POPEVAL. */
2893 op_free(PL_eval_root);
2894 PL_eval_root = Nullop;
2896 SP = PL_stack_base + POPMARK; /* pop original mark */
2898 POPBLOCK(cx,PL_curpm);
2904 if (optype == OP_REQUIRE) {
2905 char* msg = SvPVx(ERRSV, n_a);
2906 DIE(aTHX_ "%sCompilation failed in require",
2907 *msg ? msg : "Unknown error\n");
2910 char* msg = SvPVx(ERRSV, n_a);
2912 POPBLOCK(cx,PL_curpm);
2914 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2915 (*msg ? msg : "Unknown error\n"));
2917 SvREFCNT_dec(PL_rs);
2918 PL_rs = SvREFCNT_inc(PL_nrs);
2920 MUTEX_LOCK(&PL_eval_mutex);
2922 COND_SIGNAL(&PL_eval_cond);
2923 MUTEX_UNLOCK(&PL_eval_mutex);
2924 #endif /* USE_THREADS */
2927 SvREFCNT_dec(PL_rs);
2928 PL_rs = SvREFCNT_inc(PL_nrs);
2929 CopLINE_set(&PL_compiling, 0);
2931 *startop = PL_eval_root;
2932 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2933 CvOUTSIDE(PL_compcv) = Nullcv;
2935 SAVEFREEOP(PL_eval_root);
2937 scalarvoid(PL_eval_root);
2938 else if (gimme & G_ARRAY)
2941 scalar(PL_eval_root);
2943 DEBUG_x(dump_eval());
2945 /* Register with debugger: */
2946 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2947 CV *cv = get_cv("DB::postponed", FALSE);
2951 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2953 call_sv((SV*)cv, G_DISCARD);
2957 /* compiled okay, so do it */
2959 CvDEPTH(PL_compcv) = 1;
2960 SP = PL_stack_base + POPMARK; /* pop original mark */
2961 PL_op = saveop; /* The caller may need it. */
2962 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2964 MUTEX_LOCK(&PL_eval_mutex);
2966 COND_SIGNAL(&PL_eval_cond);
2967 MUTEX_UNLOCK(&PL_eval_mutex);
2968 #endif /* USE_THREADS */
2970 RETURNOP(PL_eval_start);
2974 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2976 STRLEN namelen = strlen(name);
2979 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2980 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2981 char *pmc = SvPV_nolen(pmcsv);
2984 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2985 fp = PerlIO_open(name, mode);
2988 if (PerlLIO_stat(name, &pmstat) < 0 ||
2989 pmstat.st_mtime < pmcstat.st_mtime)
2991 fp = PerlIO_open(pmc, mode);
2994 fp = PerlIO_open(name, mode);
2997 SvREFCNT_dec(pmcsv);
3000 fp = PerlIO_open(name, mode);
3008 register PERL_CONTEXT *cx;
3013 SV *namesv = Nullsv;
3015 I32 gimme = G_SCALAR;
3016 PerlIO *tryrsfp = 0;
3018 int filter_has_file = 0;
3019 GV *filter_child_proc = 0;
3020 SV *filter_state = 0;
3025 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3026 UV rev = 0, ver = 0, sver = 0;
3028 U8 *s = (U8*)SvPVX(sv);
3029 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3031 rev = utf8_to_uv(s, end - s, &len, 0);
3034 ver = utf8_to_uv(s, end - s, &len, 0);
3037 sver = utf8_to_uv(s, end - s, &len, 0);
3040 if (PERL_REVISION < rev
3041 || (PERL_REVISION == rev
3042 && (PERL_VERSION < ver
3043 || (PERL_VERSION == ver
3044 && PERL_SUBVERSION < sver))))
3046 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3047 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3048 PERL_VERSION, PERL_SUBVERSION);
3052 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3053 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3054 + ((NV)PERL_SUBVERSION/(NV)1000000)
3055 + 0.00000099 < SvNV(sv))
3059 NV nver = (nrev - rev) * 1000;
3060 UV ver = (UV)(nver + 0.0009);
3061 NV nsver = (nver - ver) * 1000;
3062 UV sver = (UV)(nsver + 0.0009);
3064 /* help out with the "use 5.6" confusion */
3065 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3066 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3067 "this is only v%d.%d.%d, stopped"
3068 " (did you mean v%"UVuf".%"UVuf".0?)",
3069 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3070 PERL_SUBVERSION, rev, ver/100);
3073 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3074 "this is only v%d.%d.%d, stopped",
3075 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3082 name = SvPV(sv, len);
3083 if (!(name && len > 0 && *name))
3084 DIE(aTHX_ "Null filename used");
3085 TAINT_PROPER("require");
3086 if (PL_op->op_type == OP_REQUIRE &&
3087 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3088 *svp != &PL_sv_undef)
3091 /* prepare to compile file */
3093 if (PERL_FILE_IS_ABSOLUTE(name)
3094 || (*name == '.' && (name[1] == '/' ||
3095 (name[1] == '.' && name[2] == '/'))))
3098 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3099 #ifdef MACOS_TRADITIONAL
3100 /* We consider paths of the form :a:b ambiguous and interpret them first
3101 as global then as local
3103 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3112 AV *ar = GvAVn(PL_incgv);
3116 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3119 namesv = NEWSV(806, 0);
3120 for (i = 0; i <= AvFILL(ar); i++) {
3121 SV *dirsv = *av_fetch(ar, i, TRUE);
3127 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3128 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3131 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3132 PTR2UV(SvANY(loader)), name);
3133 tryname = SvPVX(namesv);
3144 count = call_sv(loader, G_ARRAY);
3154 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3158 if (SvTYPE(arg) == SVt_PVGV) {
3159 IO *io = GvIO((GV *)arg);
3164 tryrsfp = IoIFP(io);
3165 if (IoTYPE(io) == IoTYPE_PIPE) {
3166 /* reading from a child process doesn't
3167 nest -- when returning from reading
3168 the inner module, the outer one is
3169 unreadable (closed?) I've tried to
3170 save the gv to manage the lifespan of
3171 the pipe, but this didn't help. XXX */
3172 filter_child_proc = (GV *)arg;
3173 (void)SvREFCNT_inc(filter_child_proc);
3176 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3177 PerlIO_close(IoOFP(io));
3189 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3191 (void)SvREFCNT_inc(filter_sub);
3194 filter_state = SP[i];
3195 (void)SvREFCNT_inc(filter_state);
3199 tryrsfp = PerlIO_open("/dev/null",
3213 filter_has_file = 0;
3214 if (filter_child_proc) {
3215 SvREFCNT_dec(filter_child_proc);
3216 filter_child_proc = 0;
3219 SvREFCNT_dec(filter_state);
3223 SvREFCNT_dec(filter_sub);
3228 char *dir = SvPVx(dirsv, n_a);
3229 #ifdef MACOS_TRADITIONAL
3231 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3235 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3237 sv_setpv(namesv, unixdir);
3238 sv_catpv(namesv, unixname);
3240 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3243 TAINT_PROPER("require");
3244 tryname = SvPVX(namesv);
3245 #ifdef MACOS_TRADITIONAL
3247 /* Convert slashes in the name part, but not the directory part, to colons */
3249 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3253 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3255 if (tryname[0] == '.' && tryname[1] == '/')
3263 SAVECOPFILE_FREE(&PL_compiling);
3264 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3265 SvREFCNT_dec(namesv);
3267 if (PL_op->op_type == OP_REQUIRE) {
3268 char *msgstr = name;
3269 if (namesv) { /* did we lookup @INC? */
3270 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3271 SV *dirmsgsv = NEWSV(0, 0);
3272 AV *ar = GvAVn(PL_incgv);
3274 sv_catpvn(msg, " in @INC", 8);
3275 if (instr(SvPVX(msg), ".h "))
3276 sv_catpv(msg, " (change .h to .ph maybe?)");
3277 if (instr(SvPVX(msg), ".ph "))
3278 sv_catpv(msg, " (did you run h2ph?)");
3279 sv_catpv(msg, " (@INC contains:");
3280 for (i = 0; i <= AvFILL(ar); i++) {
3281 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3282 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3283 sv_catsv(msg, dirmsgsv);
3285 sv_catpvn(msg, ")", 1);
3286 SvREFCNT_dec(dirmsgsv);
3287 msgstr = SvPV_nolen(msg);
3289 DIE(aTHX_ "Can't locate %s", msgstr);
3295 SETERRNO(0, SS$_NORMAL);
3297 /* Assume success here to prevent recursive requirement. */
3298 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3299 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3303 lex_start(sv_2mortal(newSVpvn("",0)));
3304 SAVEGENERICSV(PL_rsfp_filters);
3305 PL_rsfp_filters = Nullav;
3310 SAVESPTR(PL_compiling.cop_warnings);
3311 if (PL_dowarn & G_WARN_ALL_ON)
3312 PL_compiling.cop_warnings = pWARN_ALL ;
3313 else if (PL_dowarn & G_WARN_ALL_OFF)
3314 PL_compiling.cop_warnings = pWARN_NONE ;
3316 PL_compiling.cop_warnings = pWARN_STD ;
3317 SAVESPTR(PL_compiling.cop_io);
3318 PL_compiling.cop_io = Nullsv;
3320 if (filter_sub || filter_child_proc) {
3321 SV *datasv = filter_add(run_user_filter, Nullsv);
3322 IoLINES(datasv) = filter_has_file;
3323 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3324 IoTOP_GV(datasv) = (GV *)filter_state;
3325 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3328 /* switch to eval mode */
3329 push_return(PL_op->op_next);
3330 PUSHBLOCK(cx, CXt_EVAL, SP);
3331 PUSHEVAL(cx, name, Nullgv);
3333 SAVECOPLINE(&PL_compiling);
3334 CopLINE_set(&PL_compiling, 0);
3338 MUTEX_LOCK(&PL_eval_mutex);
3339 if (PL_eval_owner && PL_eval_owner != thr)
3340 while (PL_eval_owner)
3341 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3342 PL_eval_owner = thr;
3343 MUTEX_UNLOCK(&PL_eval_mutex);
3344 #endif /* USE_THREADS */
3345 return DOCATCH(doeval(G_SCALAR, NULL));
3350 return pp_require();
3356 register PERL_CONTEXT *cx;
3358 I32 gimme = GIMME_V, was = PL_sub_generation;
3359 char tbuf[TYPE_DIGITS(long) + 12];
3360 char *tmpbuf = tbuf;
3365 if (!SvPV(sv,len) || !len)
3367 TAINT_PROPER("eval");
3373 /* switch to eval mode */
3375 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3376 SV *sv = sv_newmortal();
3377 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3378 (unsigned long)++PL_evalseq,
3379 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3383 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3384 SAVECOPFILE_FREE(&PL_compiling);
3385 CopFILE_set(&PL_compiling, tmpbuf+2);
3386 SAVECOPLINE(&PL_compiling);
3387 CopLINE_set(&PL_compiling, 1);
3388 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3389 deleting the eval's FILEGV from the stash before gv_check() runs
3390 (i.e. before run-time proper). To work around the coredump that
3391 ensues, we always turn GvMULTI_on for any globals that were
3392 introduced within evals. See force_ident(). GSAR 96-10-12 */
3393 safestr = savepv(tmpbuf);
3394 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3396 PL_hints = PL_op->op_targ;
3397 SAVESPTR(PL_compiling.cop_warnings);
3398 if (specialWARN(PL_curcop->cop_warnings))
3399 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3401 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3402 SAVEFREESV(PL_compiling.cop_warnings);
3404 SAVESPTR(PL_compiling.cop_io);
3405 if (specialCopIO(PL_curcop->cop_io))
3406 PL_compiling.cop_io = PL_curcop->cop_io;
3408 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3409 SAVEFREESV(PL_compiling.cop_io);
3412 push_return(PL_op->op_next);
3413 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3414 PUSHEVAL(cx, 0, Nullgv);
3416 /* prepare to compile string */
3418 if (PERLDB_LINE && PL_curstash != PL_debstash)
3419 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3422 MUTEX_LOCK(&PL_eval_mutex);
3423 if (PL_eval_owner && PL_eval_owner != thr)
3424 while (PL_eval_owner)
3425 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3426 PL_eval_owner = thr;
3427 MUTEX_UNLOCK(&PL_eval_mutex);
3428 #endif /* USE_THREADS */
3429 ret = doeval(gimme, NULL);
3430 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3431 && ret != PL_op->op_next) { /* Successive compilation. */
3432 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3434 return DOCATCH(ret);
3444 register PERL_CONTEXT *cx;
3446 U8 save_flags = PL_op -> op_flags;
3451 retop = pop_return();
3454 if (gimme == G_VOID)
3456 else if (gimme == G_SCALAR) {
3459 if (SvFLAGS(TOPs) & SVs_TEMP)
3462 *MARK = sv_mortalcopy(TOPs);
3466 *MARK = &PL_sv_undef;
3471 /* in case LEAVE wipes old return values */
3472 for (mark = newsp + 1; mark <= SP; mark++) {
3473 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3474 *mark = sv_mortalcopy(*mark);
3475 TAINT_NOT; /* Each item is independent */
3479 PL_curpm = newpm; /* Don't pop $1 et al till now */
3481 if (AvFILLp(PL_comppad_name) >= 0)
3485 assert(CvDEPTH(PL_compcv) == 1);
3487 CvDEPTH(PL_compcv) = 0;
3490 if (optype == OP_REQUIRE &&
3491 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3493 /* Unassume the success we assumed earlier. */
3494 SV *nsv = cx->blk_eval.old_namesv;
3495 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3496 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3497 /* die_where() did LEAVE, or we won't be here */
3501 if (!(save_flags & OPf_SPECIAL))
3511 register PERL_CONTEXT *cx;
3512 I32 gimme = GIMME_V;
3517 push_return(cLOGOP->op_other->op_next);
3518 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3520 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3522 PL_in_eval = EVAL_INEVAL;
3525 return DOCATCH(PL_op->op_next);
3535 register PERL_CONTEXT *cx;
3543 if (gimme == G_VOID)
3545 else if (gimme == G_SCALAR) {
3548 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3551 *MARK = sv_mortalcopy(TOPs);
3555 *MARK = &PL_sv_undef;
3560 /* in case LEAVE wipes old return values */
3561 for (mark = newsp + 1; mark <= SP; mark++) {
3562 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3563 *mark = sv_mortalcopy(*mark);
3564 TAINT_NOT; /* Each item is independent */
3568 PL_curpm = newpm; /* Don't pop $1 et al till now */
3576 S_doparseform(pTHX_ SV *sv)
3579 register char *s = SvPV_force(sv, len);
3580 register char *send = s + len;
3581 register char *base;
3582 register I32 skipspaces = 0;
3585 bool postspace = FALSE;
3593 Perl_croak(aTHX_ "Null picture in formline");
3595 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3600 *fpc++ = FF_LINEMARK;
3601 noblank = repeat = FALSE;
3619 case ' ': case '\t':
3630 *fpc++ = FF_LITERAL;
3638 *fpc++ = skipspaces;
3642 *fpc++ = FF_NEWLINE;
3646 arg = fpc - linepc + 1;
3653 *fpc++ = FF_LINEMARK;
3654 noblank = repeat = FALSE;
3663 ischop = s[-1] == '^';
3669 arg = (s - base) - 1;
3671 *fpc++ = FF_LITERAL;
3680 *fpc++ = FF_LINEGLOB;
3682 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3683 arg = ischop ? 512 : 0;
3693 arg |= 256 + (s - f);
3695 *fpc++ = s - base; /* fieldsize for FETCH */
3696 *fpc++ = FF_DECIMAL;
3699 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3700 arg = ischop ? 512 : 0;
3702 s++; /* skip the '0' first */
3711 arg |= 256 + (s - f);
3713 *fpc++ = s - base; /* fieldsize for FETCH */
3714 *fpc++ = FF_0DECIMAL;
3719 bool ismore = FALSE;
3722 while (*++s == '>') ;
3723 prespace = FF_SPACE;
3725 else if (*s == '|') {
3726 while (*++s == '|') ;
3727 prespace = FF_HALFSPACE;
3732 while (*++s == '<') ;
3735 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3739 *fpc++ = s - base; /* fieldsize for FETCH */
3741 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3759 { /* need to jump to the next word */
3761 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3762 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3763 s = SvPVX(sv) + SvCUR(sv) + z;
3765 Copy(fops, s, arg, U16);
3767 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3772 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3774 * The original code was written in conjunction with BSD Computer Software
3775 * Research Group at University of California, Berkeley.
3777 * See also: "Optimistic Merge Sort" (SODA '92)
3779 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3781 * The code can be distributed under the same terms as Perl itself.
3786 #include <sys/types.h>
3791 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3792 #define Safefree(VAR) free(VAR)
3793 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3794 #endif /* TESTHARNESS */
3796 typedef char * aptr; /* pointer for arithmetic on sizes */
3797 typedef SV * gptr; /* pointers in our lists */
3799 /* Binary merge internal sort, with a few special mods
3800 ** for the special perl environment it now finds itself in.
3802 ** Things that were once options have been hotwired
3803 ** to values suitable for this use. In particular, we'll always
3804 ** initialize looking for natural runs, we'll always produce stable
3805 ** output, and we'll always do Peter McIlroy's binary merge.
3808 /* Pointer types for arithmetic and storage and convenience casts */
3810 #define APTR(P) ((aptr)(P))
3811 #define GPTP(P) ((gptr *)(P))
3812 #define GPPP(P) ((gptr **)(P))
3815 /* byte offset from pointer P to (larger) pointer Q */
3816 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3818 #define PSIZE sizeof(gptr)
3820 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3823 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3824 #define PNBYTE(N) ((N) << (PSHIFT))
3825 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3827 /* Leave optimization to compiler */
3828 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3829 #define PNBYTE(N) ((N) * (PSIZE))
3830 #define PINDEX(P, N) (GPTP(P) + (N))
3833 /* Pointer into other corresponding to pointer into this */
3834 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3836 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3839 /* Runs are identified by a pointer in the auxilliary list.
3840 ** The pointer is at the start of the list,
3841 ** and it points to the start of the next list.
3842 ** NEXT is used as an lvalue, too.
3845 #define NEXT(P) (*GPPP(P))
3848 /* PTHRESH is the minimum number of pairs with the same sense to justify
3849 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3850 ** not just elements, so PTHRESH == 8 means a run of 16.
3855 /* RTHRESH is the number of elements in a run that must compare low
3856 ** to the low element from the opposing run before we justify
3857 ** doing a binary rampup instead of single stepping.
3858 ** In random input, N in a row low should only happen with
3859 ** probability 2^(1-N), so we can risk that we are dealing
3860 ** with orderly input without paying much when we aren't.
3867 ** Overview of algorithm and variables.
3868 ** The array of elements at list1 will be organized into runs of length 2,
3869 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3870 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3872 ** Unless otherwise specified, pair pointers address the first of two elements.
3874 ** b and b+1 are a pair that compare with sense ``sense''.
3875 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3877 ** p2 parallels b in the list2 array, where runs are defined by
3880 ** t represents the ``top'' of the adjacent pairs that might extend
3881 ** the run beginning at b. Usually, t addresses a pair
3882 ** that compares with opposite sense from (b,b+1).
3883 ** However, it may also address a singleton element at the end of list1,
3884 ** or it may be equal to ``last'', the first element beyond list1.
3886 ** r addresses the Nth pair following b. If this would be beyond t,
3887 ** we back it off to t. Only when r is less than t do we consider the
3888 ** run long enough to consider checking.
3890 ** q addresses a pair such that the pairs at b through q already form a run.
3891 ** Often, q will equal b, indicating we only are sure of the pair itself.
3892 ** However, a search on the previous cycle may have revealed a longer run,
3893 ** so q may be greater than b.
3895 ** p is used to work back from a candidate r, trying to reach q,
3896 ** which would mean b through r would be a run. If we discover such a run,
3897 ** we start q at r and try to push it further towards t.
3898 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3899 ** In any event, after the check (if any), we have two main cases.
3901 ** 1) Short run. b <= q < p <= r <= t.
3902 ** b through q is a run (perhaps trivial)
3903 ** q through p are uninteresting pairs
3904 ** p through r is a run
3906 ** 2) Long run. b < r <= q < t.
3907 ** b through q is a run (of length >= 2 * PTHRESH)
3909 ** Note that degenerate cases are not only possible, but likely.
3910 ** For example, if the pair following b compares with opposite sense,
3911 ** then b == q < p == r == t.
3916 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3919 register gptr *b, *p, *q, *t, *p2;
3920 register gptr c, *last, *r;
3924 last = PINDEX(b, nmemb);
3925 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3926 for (p2 = list2; b < last; ) {
3927 /* We just started, or just reversed sense.
3928 ** Set t at end of pairs with the prevailing sense.
3930 for (p = b+2, t = p; ++p < last; t = ++p) {
3931 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3934 /* Having laid out the playing field, look for long runs */
3936 p = r = b + (2 * PTHRESH);
3937 if (r >= t) p = r = t; /* too short to care about */
3939 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3942 /* b through r is a (long) run.
3943 ** Extend it as far as possible.
3946 while (((p += 2) < t) &&
3947 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3948 r = p = q + 2; /* no simple pairs, no after-run */
3951 if (q > b) { /* run of greater than 2 at b */
3954 /* pick up singleton, if possible */
3956 ((t + 1) == last) &&
3957 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3958 savep = r = p = q = last;
3959 p2 = NEXT(p2) = p2 + (p - b);
3960 if (sense) while (b < --p) {
3967 while (q < p) { /* simple pairs */
3968 p2 = NEXT(p2) = p2 + 2;
3975 if (((b = p) == t) && ((t+1) == last)) {
3987 /* Overview of bmerge variables:
3989 ** list1 and list2 address the main and auxiliary arrays.
3990 ** They swap identities after each merge pass.
3991 ** Base points to the original list1, so we can tell if
3992 ** the pointers ended up where they belonged (or must be copied).
3994 ** When we are merging two lists, f1 and f2 are the next elements
3995 ** on the respective lists. l1 and l2 mark the end of the lists.
3996 ** tp2 is the current location in the merged list.
3998 ** p1 records where f1 started.
3999 ** After the merge, a new descriptor is built there.
4001 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4002 ** It is used to identify and delimit the runs.
4004 ** In the heat of determining where q, the greater of the f1/f2 elements,
4005 ** belongs in the other list, b, t and p, represent bottom, top and probe
4006 ** locations, respectively, in the other list.
4007 ** They make convenient temporary pointers in other places.
4011 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4015 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4016 gptr *aux, *list2, *p2, *last;
4020 if (nmemb <= 1) return; /* sorted trivially */
4021 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4023 dynprep(aTHX_ list1, list2, nmemb, cmp);
4024 last = PINDEX(list2, nmemb);
4025 while (NEXT(list2) != last) {
4026 /* More than one run remains. Do some merging to reduce runs. */
4028 for (tp2 = p2 = list2; p2 != last;) {
4029 /* The new first run begins where the old second list ended.
4030 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4034 f2 = l1 = POTHER(t, list2, list1);
4035 if (t != last) t = NEXT(t);
4036 l2 = POTHER(t, list2, list1);
4038 while (f1 < l1 && f2 < l2) {
4039 /* If head 1 is larger than head 2, find ALL the elements
4040 ** in list 2 strictly less than head1, write them all,
4041 ** then head 1. Then compare the new heads, and repeat,
4042 ** until one or both lists are exhausted.
4044 ** In all comparisons (after establishing
4045 ** which head to merge) the item to merge
4046 ** (at pointer q) is the first operand of
4047 ** the comparison. When we want to know
4048 ** if ``q is strictly less than the other'',
4050 ** cmp(q, other) < 0
4051 ** because stability demands that we treat equality
4052 ** as high when q comes from l2, and as low when
4053 ** q was from l1. So we ask the question by doing
4054 ** cmp(q, other) <= sense
4055 ** and make sense == 0 when equality should look low,
4056 ** and -1 when equality should look high.
4060 if (cmp(aTHX_ *f1, *f2) <= 0) {
4061 q = f2; b = f1; t = l1;
4064 q = f1; b = f2; t = l2;
4071 ** Leave t at something strictly
4072 ** greater than q (or at the end of the list),
4073 ** and b at something strictly less than q.
4075 for (i = 1, run = 0 ;;) {
4076 if ((p = PINDEX(b, i)) >= t) {
4078 if (((p = PINDEX(t, -1)) > b) &&
4079 (cmp(aTHX_ *q, *p) <= sense))
4083 } else if (cmp(aTHX_ *q, *p) <= sense) {
4087 if (++run >= RTHRESH) i += i;
4091 /* q is known to follow b and must be inserted before t.
4092 ** Increment b, so the range of possibilities is [b,t).
4093 ** Round binary split down, to favor early appearance.
4094 ** Adjust b and t until q belongs just before t.
4099 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4100 if (cmp(aTHX_ *q, *p) <= sense) {
4106 /* Copy all the strictly low elements */
4109 FROMTOUPTO(f2, tp2, t);
4112 FROMTOUPTO(f1, tp2, t);
4118 /* Run out remaining list */
4120 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4121 } else FROMTOUPTO(f1, tp2, l1);
4122 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4127 last = PINDEX(list2, nmemb);
4129 if (base == list2) {
4130 last = PINDEX(list1, nmemb);
4131 FROMTOUPTO(list1, list2, last);
4146 sortcv(pTHXo_ SV *a, SV *b)
4149 I32 oldsaveix = PL_savestack_ix;
4150 I32 oldscopeix = PL_scopestack_ix;
4152 GvSV(PL_firstgv) = a;
4153 GvSV(PL_secondgv) = b;
4154 PL_stack_sp = PL_stack_base;
4157 if (PL_stack_sp != PL_stack_base + 1)
4158 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4159 if (!SvNIOKp(*PL_stack_sp))
4160 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4161 result = SvIV(*PL_stack_sp);
4162 while (PL_scopestack_ix > oldscopeix) {
4165 leave_scope(oldsaveix);
4170 sortcv_stacked(pTHXo_ SV *a, SV *b)
4173 I32 oldsaveix = PL_savestack_ix;
4174 I32 oldscopeix = PL_scopestack_ix;
4179 av = (AV*)PL_curpad[0];
4181 av = GvAV(PL_defgv);
4184 if (AvMAX(av) < 1) {
4185 SV** ary = AvALLOC(av);
4186 if (AvARRAY(av) != ary) {
4187 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4188 SvPVX(av) = (char*)ary;
4190 if (AvMAX(av) < 1) {
4193 SvPVX(av) = (char*)ary;
4200 PL_stack_sp = PL_stack_base;
4203 if (PL_stack_sp != PL_stack_base + 1)
4204 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4205 if (!SvNIOKp(*PL_stack_sp))
4206 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4207 result = SvIV(*PL_stack_sp);
4208 while (PL_scopestack_ix > oldscopeix) {
4211 leave_scope(oldsaveix);
4216 sortcv_xsub(pTHXo_ SV *a, SV *b)
4219 I32 oldsaveix = PL_savestack_ix;
4220 I32 oldscopeix = PL_scopestack_ix;
4222 CV *cv=(CV*)PL_sortcop;
4230 (void)(*CvXSUB(cv))(aTHXo_ cv);
4231 if (PL_stack_sp != PL_stack_base + 1)
4232 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4233 if (!SvNIOKp(*PL_stack_sp))
4234 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4235 result = SvIV(*PL_stack_sp);
4236 while (PL_scopestack_ix > oldscopeix) {
4239 leave_scope(oldsaveix);
4245 sv_ncmp(pTHXo_ SV *a, SV *b)
4249 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4253 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4257 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4259 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4261 if (PL_amagic_generation) { \
4262 if (SvAMAGIC(left)||SvAMAGIC(right))\
4263 *svp = amagic_call(left, \
4271 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4274 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4279 I32 i = SvIVX(tmpsv);
4289 return sv_ncmp(aTHXo_ a, b);
4293 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4296 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4301 I32 i = SvIVX(tmpsv);
4311 return sv_i_ncmp(aTHXo_ a, b);
4315 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4318 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4323 I32 i = SvIVX(tmpsv);
4333 return sv_cmp(str1, str2);
4337 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4340 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4345 I32 i = SvIVX(tmpsv);
4355 return sv_cmp_locale(str1, str2);
4359 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4361 SV *datasv = FILTER_DATA(idx);
4362 int filter_has_file = IoLINES(datasv);
4363 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4364 SV *filter_state = (SV *)IoTOP_GV(datasv);
4365 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4368 /* I was having segfault trouble under Linux 2.2.5 after a
4369 parse error occured. (Had to hack around it with a test
4370 for PL_error_count == 0.) Solaris doesn't segfault --
4371 not sure where the trouble is yet. XXX */
4373 if (filter_has_file) {
4374 len = FILTER_READ(idx+1, buf_sv, maxlen);
4377 if (filter_sub && len >= 0) {
4388 PUSHs(sv_2mortal(newSViv(maxlen)));
4390 PUSHs(filter_state);
4393 count = call_sv(filter_sub, G_SCALAR);
4409 IoLINES(datasv) = 0;
4410 if (filter_child_proc) {
4411 SvREFCNT_dec(filter_child_proc);
4412 IoFMT_GV(datasv) = Nullgv;
4415 SvREFCNT_dec(filter_state);
4416 IoTOP_GV(datasv) = Nullgv;
4419 SvREFCNT_dec(filter_sub);
4420 IoBOTTOM_GV(datasv) = Nullgv;
4422 filter_del(run_user_filter);
4431 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4433 return sv_cmp_locale(str1, str2);
4437 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4439 return sv_cmp(str1, str2);
4442 #endif /* PERL_OBJECT */