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;
180 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 if (pm->op_pmdynflags & PMdf_UTF8)
193 SvUTF8_on(targ); /* could also copy SvUTF8(dstr)? */
194 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
196 (void)SvPOK_only_UTF8(targ);
197 TAINT_IF(cx->sb_rxtainted);
201 LEAVE_SCOPE(cx->sb_oldsave);
203 RETURNOP(pm->op_next);
206 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
209 cx->sb_orig = orig = rx->subbeg;
211 cx->sb_strend = s + (cx->sb_strend - m);
213 cx->sb_m = m = rx->startp[0] + orig;
215 sv_catpvn(dstr, s, m-s);
216 cx->sb_s = rx->endp[0] + orig;
217 { /* Update the pos() information. */
218 SV *sv = cx->sb_targ;
221 if (SvTYPE(sv) < SVt_PVMG)
222 SvUPGRADE(sv, SVt_PVMG);
223 if (!(mg = mg_find(sv, 'g'))) {
224 sv_magic(sv, Nullsv, 'g', Nullch, 0);
225 mg = mg_find(sv, 'g');
232 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
233 rxres_save(&cx->sb_rxres, rx);
234 RETURNOP(pm->op_pmreplstart);
238 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
243 if (!p || p[1] < rx->nparens) {
244 i = 6 + rx->nparens * 2;
252 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
253 RX_MATCH_COPIED_off(rx);
257 *p++ = PTR2UV(rx->subbeg);
258 *p++ = (UV)rx->sublen;
259 for (i = 0; i <= rx->nparens; ++i) {
260 *p++ = (UV)rx->startp[i];
261 *p++ = (UV)rx->endp[i];
266 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
271 if (RX_MATCH_COPIED(rx))
272 Safefree(rx->subbeg);
273 RX_MATCH_COPIED_set(rx, *p);
278 rx->subbeg = INT2PTR(char*,*p++);
279 rx->sublen = (I32)(*p++);
280 for (i = 0; i <= rx->nparens; ++i) {
281 rx->startp[i] = (I32)(*p++);
282 rx->endp[i] = (I32)(*p++);
287 Perl_rxres_free(pTHX_ void **rsp)
292 Safefree(INT2PTR(char*,*p));
300 djSP; dMARK; dORIGMARK;
301 register SV *tmpForm = *++MARK;
313 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
319 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
320 bool item_is_utf = FALSE;
322 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
323 if (SvREADONLY(tmpForm)) {
324 SvREADONLY_off(tmpForm);
325 doparseform(tmpForm);
326 SvREADONLY_on(tmpForm);
329 doparseform(tmpForm);
332 SvPV_force(PL_formtarget, len);
333 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
335 f = SvPV(tmpForm, len);
336 /* need to jump to the next word */
337 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
346 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
347 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
348 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
349 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
350 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
352 case FF_CHECKNL: name = "CHECKNL"; break;
353 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
354 case FF_SPACE: name = "SPACE"; break;
355 case FF_HALFSPACE: name = "HALFSPACE"; break;
356 case FF_ITEM: name = "ITEM"; break;
357 case FF_CHOP: name = "CHOP"; break;
358 case FF_LINEGLOB: name = "LINEGLOB"; break;
359 case FF_NEWLINE: name = "NEWLINE"; break;
360 case FF_MORE: name = "MORE"; break;
361 case FF_LINEMARK: name = "LINEMARK"; break;
362 case FF_END: name = "END"; break;
363 case FF_0DECIMAL: name = "0DECIMAL"; break;
366 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
368 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
396 if (ckWARN(WARN_SYNTAX))
397 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
402 item = s = SvPV(sv, len);
405 itemsize = sv_len_utf8(sv);
406 if (itemsize != len) {
408 if (itemsize > fieldsize) {
409 itemsize = fieldsize;
410 itembytes = itemsize;
411 sv_pos_u2b(sv, &itembytes, 0);
415 send = chophere = s + itembytes;
425 sv_pos_b2u(sv, &itemsize);
430 if (itemsize > fieldsize)
431 itemsize = fieldsize;
432 send = chophere = s + itemsize;
444 item = s = SvPV(sv, len);
447 itemsize = sv_len_utf8(sv);
448 if (itemsize != len) {
450 if (itemsize <= fieldsize) {
451 send = chophere = s + itemsize;
462 itemsize = fieldsize;
463 itembytes = itemsize;
464 sv_pos_u2b(sv, &itembytes, 0);
465 send = chophere = s + itembytes;
466 while (s < send || (s == send && isSPACE(*s))) {
476 if (strchr(PL_chopset, *s))
481 itemsize = chophere - item;
482 sv_pos_b2u(sv, &itemsize);
489 if (itemsize <= fieldsize) {
490 send = chophere = s + itemsize;
501 itemsize = fieldsize;
502 send = chophere = s + itemsize;
503 while (s < send || (s == send && isSPACE(*s))) {
513 if (strchr(PL_chopset, *s))
518 itemsize = chophere - item;
523 arg = fieldsize - itemsize;
532 arg = fieldsize - itemsize;
547 switch (UTF8SKIP(s)) {
558 if ( !((*t++ = *s++) & ~31) )
566 int ch = *t++ = *s++;
569 if ( !((*t++ = *s++) & ~31) )
578 while (*s && isSPACE(*s))
585 item = s = SvPV(sv, len);
587 item_is_utf = FALSE; /* XXX is this correct? */
599 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
600 sv_catpvn(PL_formtarget, item, itemsize);
601 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
602 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
607 /* If the field is marked with ^ and the value is undefined,
610 if ((arg & 512) && !SvOK(sv)) {
618 /* Formats aren't yet marked for locales, so assume "yes". */
620 STORE_NUMERIC_STANDARD_SET_LOCAL();
621 #if defined(USE_LONG_DOUBLE)
623 sprintf(t, "%#*.*" PERL_PRIfldbl,
624 (int) fieldsize, (int) arg & 255, value);
626 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
631 (int) fieldsize, (int) arg & 255, value);
634 (int) fieldsize, value);
637 RESTORE_NUMERIC_STANDARD();
643 /* If the field is marked with ^ and the value is undefined,
646 if ((arg & 512) && !SvOK(sv)) {
654 /* Formats aren't yet marked for locales, so assume "yes". */
656 STORE_NUMERIC_STANDARD_SET_LOCAL();
657 #if defined(USE_LONG_DOUBLE)
659 sprintf(t, "%#0*.*" PERL_PRIfldbl,
660 (int) fieldsize, (int) arg & 255, value);
661 /* is this legal? I don't have long doubles */
663 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
667 sprintf(t, "%#0*.*f",
668 (int) fieldsize, (int) arg & 255, value);
671 (int) fieldsize, value);
674 RESTORE_NUMERIC_STANDARD();
681 while (t-- > linemark && *t == ' ') ;
689 if (arg) { /* repeat until fields exhausted? */
691 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
692 lines += FmLINES(PL_formtarget);
695 if (strnEQ(linemark, linemark - arg, arg))
696 DIE(aTHX_ "Runaway format");
698 FmLINES(PL_formtarget) = lines;
700 RETURNOP(cLISTOP->op_first);
713 while (*s && isSPACE(*s) && s < send)
717 arg = fieldsize - itemsize;
724 if (strnEQ(s," ",3)) {
725 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
736 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
737 FmLINES(PL_formtarget) += lines;
749 if (PL_stack_base + *PL_markstack_ptr == SP) {
751 if (GIMME_V == G_SCALAR)
752 XPUSHs(sv_2mortal(newSViv(0)));
753 RETURNOP(PL_op->op_next->op_next);
755 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
756 pp_pushmark(); /* push dst */
757 pp_pushmark(); /* push src */
758 ENTER; /* enter outer scope */
761 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
763 ENTER; /* enter inner scope */
766 src = PL_stack_base[*PL_markstack_ptr];
771 if (PL_op->op_type == OP_MAPSTART)
772 pp_pushmark(); /* push top */
773 return ((LOGOP*)PL_op->op_next)->op_other;
778 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
784 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
790 /* first, move source pointer to the next item in the source list */
791 ++PL_markstack_ptr[-1];
793 /* if there are new items, push them into the destination list */
795 /* might need to make room back there first */
796 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
797 /* XXX this implementation is very pessimal because the stack
798 * is repeatedly extended for every set of items. Is possible
799 * to do this without any stack extension or copying at all
800 * by maintaining a separate list over which the map iterates
801 * (like foreach does). --gsar */
803 /* everything in the stack after the destination list moves
804 * towards the end the stack by the amount of room needed */
805 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
807 /* items to shift up (accounting for the moved source pointer) */
808 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
810 /* This optimization is by Ben Tilly and it does
811 * things differently from what Sarathy (gsar)
812 * is describing. The downside of this optimization is
813 * that leaves "holes" (uninitialized and hopefully unused areas)
814 * to the Perl stack, but on the other hand this
815 * shouldn't be a problem. If Sarathy's idea gets
816 * implemented, this optimization should become
817 * irrelevant. --jhi */
819 shift = count; /* Avoid shifting too often --Ben Tilly */
824 PL_markstack_ptr[-1] += shift;
825 *PL_markstack_ptr += shift;
829 /* copy the new items down to the destination list */
830 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
832 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
834 LEAVE; /* exit inner scope */
837 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
840 (void)POPMARK; /* pop top */
841 LEAVE; /* exit outer scope */
842 (void)POPMARK; /* pop src */
843 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
844 (void)POPMARK; /* pop dst */
845 SP = PL_stack_base + POPMARK; /* pop original mark */
846 if (gimme == G_SCALAR) {
850 else if (gimme == G_ARRAY)
857 ENTER; /* enter inner scope */
860 /* set $_ to the new source item */
861 src = PL_stack_base[PL_markstack_ptr[-1]];
865 RETURNOP(cLOGOP->op_other);
871 djSP; dMARK; dORIGMARK;
873 SV **myorigmark = ORIGMARK;
879 OP* nextop = PL_op->op_next;
881 bool hasargs = FALSE;
884 if (gimme != G_ARRAY) {
890 SAVEVPTR(PL_sortcop);
891 if (PL_op->op_flags & OPf_STACKED) {
892 if (PL_op->op_flags & OPf_SPECIAL) {
893 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
894 kid = kUNOP->op_first; /* pass rv2gv */
895 kid = kUNOP->op_first; /* pass leave */
896 PL_sortcop = kid->op_next;
897 stash = CopSTASH(PL_curcop);
900 cv = sv_2cv(*++MARK, &stash, &gv, 0);
901 if (cv && SvPOK(cv)) {
903 char *proto = SvPV((SV*)cv, n_a);
904 if (proto && strEQ(proto, "$$")) {
908 if (!(cv && CvROOT(cv))) {
909 if (cv && CvXSUB(cv)) {
913 SV *tmpstr = sv_newmortal();
914 gv_efullname3(tmpstr, gv, Nullch);
915 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
919 DIE(aTHX_ "Undefined subroutine in sort");
924 PL_sortcop = (OP*)cv;
926 PL_sortcop = CvSTART(cv);
927 SAVEVPTR(CvROOT(cv)->op_ppaddr);
928 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
931 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
937 stash = CopSTASH(PL_curcop);
941 while (MARK < SP) { /* This may or may not shift down one here. */
943 if ((*up = *++MARK)) { /* Weed out nulls. */
945 if (!PL_sortcop && !SvPOK(*up)) {
950 (void)sv_2pv(*up, &n_a);
955 max = --up - myorigmark;
960 bool oldcatch = CATCH_GET;
966 PUSHSTACKi(PERLSI_SORT);
967 if (!hasargs && !is_xsub) {
968 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
969 SAVESPTR(PL_firstgv);
970 SAVESPTR(PL_secondgv);
971 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
972 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
973 PL_sortstash = stash;
976 sv_lock((SV *)PL_firstgv);
977 sv_lock((SV *)PL_secondgv);
979 SAVESPTR(GvSV(PL_firstgv));
980 SAVESPTR(GvSV(PL_secondgv));
983 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
984 if (!(PL_op->op_flags & OPf_SPECIAL)) {
985 cx->cx_type = CXt_SUB;
986 cx->blk_gimme = G_SCALAR;
989 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
991 PL_sortcxix = cxstack_ix;
993 if (hasargs && !is_xsub) {
994 /* This is mostly copied from pp_entersub */
995 AV *av = (AV*)PL_curpad[0];
998 cx->blk_sub.savearray = GvAV(PL_defgv);
999 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1000 #endif /* USE_THREADS */
1001 cx->blk_sub.oldcurpad = PL_curpad;
1002 cx->blk_sub.argarray = av;
1004 qsortsv((myorigmark+1), max,
1005 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1007 POPBLOCK(cx,PL_curpm);
1008 PL_stack_sp = newsp;
1010 CATCH_SET(oldcatch);
1015 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1016 qsortsv(ORIGMARK+1, max,
1017 (PL_op->op_private & OPpSORT_NUMERIC)
1018 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1019 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1020 : ( overloading ? amagic_ncmp : sv_ncmp))
1021 : ( (PL_op->op_private & OPpLOCALE)
1024 : sv_cmp_locale_static)
1025 : ( overloading ? amagic_cmp : sv_cmp_static)));
1026 if (PL_op->op_private & OPpSORT_REVERSE) {
1027 SV **p = ORIGMARK+1;
1028 SV **q = ORIGMARK+max;
1038 PL_stack_sp = ORIGMARK + max;
1046 if (GIMME == G_ARRAY)
1048 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1049 return cLOGOP->op_other;
1058 if (GIMME == G_ARRAY) {
1059 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1063 SV *targ = PAD_SV(PL_op->op_targ);
1066 if (PL_op->op_private & OPpFLIP_LINENUM) {
1068 flip = PL_last_in_gv
1069 && (gp_io = GvIOp(PL_last_in_gv))
1070 && SvIV(sv) == (IV)IoLINES(gp_io);
1075 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1076 if (PL_op->op_flags & OPf_SPECIAL) {
1084 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1097 if (GIMME == G_ARRAY) {
1103 if (SvGMAGICAL(left))
1105 if (SvGMAGICAL(right))
1108 if (SvNIOKp(left) || !SvPOKp(left) ||
1109 SvNIOKp(right) || !SvPOKp(right) ||
1110 (looks_like_number(left) && *SvPVX(left) != '0' &&
1111 looks_like_number(right) && *SvPVX(right) != '0'))
1113 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1114 DIE(aTHX_ "Range iterator outside integer range");
1125 sv = sv_2mortal(newSViv(i++));
1130 SV *final = sv_mortalcopy(right);
1132 char *tmps = SvPV(final, len);
1134 sv = sv_mortalcopy(left);
1136 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1138 if (strEQ(SvPVX(sv),tmps))
1140 sv = sv_2mortal(newSVsv(sv));
1147 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1149 if ((PL_op->op_private & OPpFLIP_LINENUM)
1150 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1152 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1153 sv_catpv(targ, "E0");
1164 S_dopoptolabel(pTHX_ char *label)
1167 register PERL_CONTEXT *cx;
1169 for (i = cxstack_ix; i >= 0; i--) {
1171 switch (CxTYPE(cx)) {
1173 if (ckWARN(WARN_EXITING))
1174 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1175 PL_op_name[PL_op->op_type]);
1178 if (ckWARN(WARN_EXITING))
1179 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1180 PL_op_name[PL_op->op_type]);
1183 if (ckWARN(WARN_EXITING))
1184 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1185 PL_op_name[PL_op->op_type]);
1188 if (ckWARN(WARN_EXITING))
1189 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1190 PL_op_name[PL_op->op_type]);
1193 if (ckWARN(WARN_EXITING))
1194 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1195 PL_op_name[PL_op->op_type]);
1198 if (!cx->blk_loop.label ||
1199 strNE(label, cx->blk_loop.label) ) {
1200 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1201 (long)i, cx->blk_loop.label));
1204 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1212 Perl_dowantarray(pTHX)
1214 I32 gimme = block_gimme();
1215 return (gimme == G_VOID) ? G_SCALAR : gimme;
1219 Perl_block_gimme(pTHX)
1223 cxix = dopoptosub(cxstack_ix);
1227 switch (cxstack[cxix].blk_gimme) {
1235 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1242 S_dopoptosub(pTHX_ I32 startingblock)
1244 return dopoptosub_at(cxstack, startingblock);
1248 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1251 register PERL_CONTEXT *cx;
1252 for (i = startingblock; i >= 0; i--) {
1254 switch (CxTYPE(cx)) {
1260 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1268 S_dopoptoeval(pTHX_ I32 startingblock)
1271 register PERL_CONTEXT *cx;
1272 for (i = startingblock; i >= 0; i--) {
1274 switch (CxTYPE(cx)) {
1278 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1286 S_dopoptoloop(pTHX_ I32 startingblock)
1289 register PERL_CONTEXT *cx;
1290 for (i = startingblock; i >= 0; i--) {
1292 switch (CxTYPE(cx)) {
1294 if (ckWARN(WARN_EXITING))
1295 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1296 PL_op_name[PL_op->op_type]);
1299 if (ckWARN(WARN_EXITING))
1300 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1301 PL_op_name[PL_op->op_type]);
1304 if (ckWARN(WARN_EXITING))
1305 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1306 PL_op_name[PL_op->op_type]);
1309 if (ckWARN(WARN_EXITING))
1310 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1311 PL_op_name[PL_op->op_type]);
1314 if (ckWARN(WARN_EXITING))
1315 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1316 PL_op_name[PL_op->op_type]);
1319 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1327 Perl_dounwind(pTHX_ I32 cxix)
1329 register PERL_CONTEXT *cx;
1332 while (cxstack_ix > cxix) {
1334 cx = &cxstack[cxstack_ix];
1335 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1336 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1337 /* Note: we don't need to restore the base context info till the end. */
1338 switch (CxTYPE(cx)) {
1341 continue; /* not break */
1363 * Closures mentioned at top level of eval cannot be referenced
1364 * again, and their presence indirectly causes a memory leak.
1365 * (Note that the fact that compcv and friends are still set here
1366 * is, AFAIK, an accident.) --Chip
1368 * XXX need to get comppad et al from eval's cv rather than
1369 * relying on the incidental global values.
1372 S_free_closures(pTHX)
1374 SV **svp = AvARRAY(PL_comppad_name);
1376 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1378 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1380 svp[ix] = &PL_sv_undef;
1384 SvREFCNT_dec(CvOUTSIDE(sv));
1385 CvOUTSIDE(sv) = Nullcv;
1398 Perl_qerror(pTHX_ SV *err)
1401 sv_catsv(ERRSV, err);
1403 sv_catsv(PL_errors, err);
1405 Perl_warn(aTHX_ "%"SVf, err);
1410 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1415 register PERL_CONTEXT *cx;
1420 if (PL_in_eval & EVAL_KEEPERR) {
1421 static char prefix[] = "\t(in cleanup) ";
1426 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1429 if (*e != *message || strNE(e,message))
1433 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1434 sv_catpvn(err, prefix, sizeof(prefix)-1);
1435 sv_catpvn(err, message, msglen);
1436 if (ckWARN(WARN_MISC)) {
1437 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1438 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1443 sv_setpvn(ERRSV, message, msglen);
1446 message = SvPVx(ERRSV, msglen);
1448 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1449 && PL_curstackinfo->si_prev)
1458 if (cxix < cxstack_ix)
1461 POPBLOCK(cx,PL_curpm);
1462 if (CxTYPE(cx) != CXt_EVAL) {
1463 PerlIO_write(Perl_error_log, "panic: die ", 11);
1464 PerlIO_write(Perl_error_log, message, msglen);
1469 if (gimme == G_SCALAR)
1470 *++newsp = &PL_sv_undef;
1471 PL_stack_sp = newsp;
1475 /* LEAVE could clobber PL_curcop (see save_re_context())
1476 * XXX it might be better to find a way to avoid messing with
1477 * PL_curcop in save_re_context() instead, but this is a more
1478 * minimal fix --GSAR */
1479 PL_curcop = cx->blk_oldcop;
1481 if (optype == OP_REQUIRE) {
1482 char* msg = SvPVx(ERRSV, n_a);
1483 DIE(aTHX_ "%sCompilation failed in require",
1484 *msg ? msg : "Unknown error\n");
1486 return pop_return();
1490 message = SvPVx(ERRSV, msglen);
1493 /* SFIO can really mess with your errno */
1496 PerlIO *serr = Perl_error_log;
1498 PerlIO_write(serr, message, msglen);
1499 (void)PerlIO_flush(serr);
1512 if (SvTRUE(left) != SvTRUE(right))
1524 RETURNOP(cLOGOP->op_other);
1533 RETURNOP(cLOGOP->op_other);
1539 register I32 cxix = dopoptosub(cxstack_ix);
1540 register PERL_CONTEXT *cx;
1541 register PERL_CONTEXT *ccstack = cxstack;
1542 PERL_SI *top_si = PL_curstackinfo;
1553 /* we may be in a higher stacklevel, so dig down deeper */
1554 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1555 top_si = top_si->si_prev;
1556 ccstack = top_si->si_cxstack;
1557 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1560 if (GIMME != G_ARRAY)
1564 if (PL_DBsub && cxix >= 0 &&
1565 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1569 cxix = dopoptosub_at(ccstack, cxix - 1);
1572 cx = &ccstack[cxix];
1573 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1574 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1575 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1576 field below is defined for any cx. */
1577 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1578 cx = &ccstack[dbcxix];
1581 stashname = CopSTASHPV(cx->blk_oldcop);
1582 if (GIMME != G_ARRAY) {
1584 PUSHs(&PL_sv_undef);
1587 sv_setpv(TARG, stashname);
1594 PUSHs(&PL_sv_undef);
1596 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1597 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1598 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1601 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1602 /* So is ccstack[dbcxix]. */
1604 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1605 PUSHs(sv_2mortal(sv));
1606 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1609 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1610 PUSHs(sv_2mortal(newSViv(0)));
1612 gimme = (I32)cx->blk_gimme;
1613 if (gimme == G_VOID)
1614 PUSHs(&PL_sv_undef);
1616 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1617 if (CxTYPE(cx) == CXt_EVAL) {
1619 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1620 PUSHs(cx->blk_eval.cur_text);
1624 else if (cx->blk_eval.old_namesv) {
1625 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1628 /* eval BLOCK (try blocks have old_namesv == 0) */
1630 PUSHs(&PL_sv_undef);
1631 PUSHs(&PL_sv_undef);
1635 PUSHs(&PL_sv_undef);
1636 PUSHs(&PL_sv_undef);
1638 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1639 && CopSTASH_eq(PL_curcop, PL_debstash))
1641 AV *ary = cx->blk_sub.argarray;
1642 int off = AvARRAY(ary) - AvALLOC(ary);
1646 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1649 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1652 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1653 av_extend(PL_dbargs, AvFILLp(ary) + off);
1654 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1655 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1657 /* XXX only hints propagated via op_private are currently
1658 * visible (others are not easily accessible, since they
1659 * use the global PL_hints) */
1660 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1661 HINT_PRIVATE_MASK)));
1664 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1666 if (old_warnings == pWARN_NONE ||
1667 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1668 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1669 else if (old_warnings == pWARN_ALL ||
1670 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1671 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1673 mask = newSVsv(old_warnings);
1674 PUSHs(sv_2mortal(mask));
1689 sv_reset(tmps, CopSTASH(PL_curcop));
1701 PL_curcop = (COP*)PL_op;
1702 TAINT_NOT; /* Each statement is presumed innocent */
1703 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1706 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1710 register PERL_CONTEXT *cx;
1711 I32 gimme = G_ARRAY;
1718 DIE(aTHX_ "No DB::DB routine defined");
1720 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1732 push_return(PL_op->op_next);
1733 PUSHBLOCK(cx, CXt_SUB, SP);
1736 (void)SvREFCNT_inc(cv);
1737 SAVEVPTR(PL_curpad);
1738 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1739 RETURNOP(CvSTART(cv));
1753 register PERL_CONTEXT *cx;
1754 I32 gimme = GIMME_V;
1756 U32 cxtype = CXt_LOOP;
1765 if (PL_op->op_flags & OPf_SPECIAL) {
1766 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1767 SAVEGENERICSV(*svp);
1771 #endif /* USE_THREADS */
1772 if (PL_op->op_targ) {
1773 #ifndef USE_ITHREADS
1774 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1777 SAVEPADSV(PL_op->op_targ);
1778 iterdata = (void*)PL_op->op_targ;
1779 cxtype |= CXp_PADVAR;
1784 svp = &GvSV(gv); /* symbol table variable */
1785 SAVEGENERICSV(*svp);
1788 iterdata = (void*)gv;
1794 PUSHBLOCK(cx, cxtype, SP);
1796 PUSHLOOP(cx, iterdata, MARK);
1798 PUSHLOOP(cx, svp, MARK);
1800 if (PL_op->op_flags & OPf_STACKED) {
1801 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1802 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1804 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1805 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1806 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1807 looks_like_number((SV*)cx->blk_loop.iterary) &&
1808 *SvPVX(cx->blk_loop.iterary) != '0'))
1810 if (SvNV(sv) < IV_MIN ||
1811 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1812 DIE(aTHX_ "Range iterator outside integer range");
1813 cx->blk_loop.iterix = SvIV(sv);
1814 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1817 cx->blk_loop.iterlval = newSVsv(sv);
1821 cx->blk_loop.iterary = PL_curstack;
1822 AvFILLp(PL_curstack) = SP - PL_stack_base;
1823 cx->blk_loop.iterix = MARK - PL_stack_base;
1832 register PERL_CONTEXT *cx;
1833 I32 gimme = GIMME_V;
1839 PUSHBLOCK(cx, CXt_LOOP, SP);
1840 PUSHLOOP(cx, 0, SP);
1848 register PERL_CONTEXT *cx;
1856 newsp = PL_stack_base + cx->blk_loop.resetsp;
1859 if (gimme == G_VOID)
1861 else if (gimme == G_SCALAR) {
1863 *++newsp = sv_mortalcopy(*SP);
1865 *++newsp = &PL_sv_undef;
1869 *++newsp = sv_mortalcopy(*++mark);
1870 TAINT_NOT; /* Each item is independent */
1876 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1877 PL_curpm = newpm; /* ... and pop $1 et al */
1889 register PERL_CONTEXT *cx;
1890 bool popsub2 = FALSE;
1891 bool clear_errsv = FALSE;
1898 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1899 if (cxstack_ix == PL_sortcxix
1900 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1902 if (cxstack_ix > PL_sortcxix)
1903 dounwind(PL_sortcxix);
1904 AvARRAY(PL_curstack)[1] = *SP;
1905 PL_stack_sp = PL_stack_base + 1;
1910 cxix = dopoptosub(cxstack_ix);
1912 DIE(aTHX_ "Can't return outside a subroutine");
1913 if (cxix < cxstack_ix)
1917 switch (CxTYPE(cx)) {
1922 if (!(PL_in_eval & EVAL_KEEPERR))
1927 if (AvFILLp(PL_comppad_name) >= 0)
1930 if (optype == OP_REQUIRE &&
1931 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1933 /* Unassume the success we assumed earlier. */
1934 SV *nsv = cx->blk_eval.old_namesv;
1935 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1936 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1943 DIE(aTHX_ "panic: return");
1947 if (gimme == G_SCALAR) {
1950 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1952 *++newsp = SvREFCNT_inc(*SP);
1957 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1959 *++newsp = sv_mortalcopy(sv);
1964 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1967 *++newsp = sv_mortalcopy(*SP);
1970 *++newsp = &PL_sv_undef;
1972 else if (gimme == G_ARRAY) {
1973 while (++MARK <= SP) {
1974 *++newsp = (popsub2 && SvTEMP(*MARK))
1975 ? *MARK : sv_mortalcopy(*MARK);
1976 TAINT_NOT; /* Each item is independent */
1979 PL_stack_sp = newsp;
1981 /* Stack values are safe: */
1983 POPSUB(cx,sv); /* release CV and @_ ... */
1987 PL_curpm = newpm; /* ... and pop $1 et al */
1993 return pop_return();
2000 register PERL_CONTEXT *cx;
2010 if (PL_op->op_flags & OPf_SPECIAL) {
2011 cxix = dopoptoloop(cxstack_ix);
2013 DIE(aTHX_ "Can't \"last\" outside a loop block");
2016 cxix = dopoptolabel(cPVOP->op_pv);
2018 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2020 if (cxix < cxstack_ix)
2025 switch (CxTYPE(cx)) {
2028 newsp = PL_stack_base + cx->blk_loop.resetsp;
2029 nextop = cx->blk_loop.last_op->op_next;
2033 nextop = pop_return();
2037 nextop = pop_return();
2041 nextop = pop_return();
2044 DIE(aTHX_ "panic: last");
2048 if (gimme == G_SCALAR) {
2050 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2051 ? *SP : sv_mortalcopy(*SP);
2053 *++newsp = &PL_sv_undef;
2055 else if (gimme == G_ARRAY) {
2056 while (++MARK <= SP) {
2057 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2058 ? *MARK : sv_mortalcopy(*MARK);
2059 TAINT_NOT; /* Each item is independent */
2065 /* Stack values are safe: */
2068 POPLOOP(cx); /* release loop vars ... */
2072 POPSUB(cx,sv); /* release CV and @_ ... */
2075 PL_curpm = newpm; /* ... and pop $1 et al */
2085 register PERL_CONTEXT *cx;
2088 if (PL_op->op_flags & OPf_SPECIAL) {
2089 cxix = dopoptoloop(cxstack_ix);
2091 DIE(aTHX_ "Can't \"next\" outside a loop block");
2094 cxix = dopoptolabel(cPVOP->op_pv);
2096 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2098 if (cxix < cxstack_ix)
2101 /* clear off anything above the scope we're re-entering, but
2102 * save the rest until after a possible continue block */
2103 inner = PL_scopestack_ix;
2105 if (PL_scopestack_ix < inner)
2106 leave_scope(PL_scopestack[PL_scopestack_ix]);
2107 return cx->blk_loop.next_op;
2113 register PERL_CONTEXT *cx;
2116 if (PL_op->op_flags & OPf_SPECIAL) {
2117 cxix = dopoptoloop(cxstack_ix);
2119 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2122 cxix = dopoptolabel(cPVOP->op_pv);
2124 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2126 if (cxix < cxstack_ix)
2130 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2131 LEAVE_SCOPE(oldsave);
2132 return cx->blk_loop.redo_op;
2136 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2140 static char too_deep[] = "Target of goto is too deeply nested";
2143 Perl_croak(aTHX_ too_deep);
2144 if (o->op_type == OP_LEAVE ||
2145 o->op_type == OP_SCOPE ||
2146 o->op_type == OP_LEAVELOOP ||
2147 o->op_type == OP_LEAVETRY)
2149 *ops++ = cUNOPo->op_first;
2151 Perl_croak(aTHX_ too_deep);
2154 if (o->op_flags & OPf_KIDS) {
2155 /* First try all the kids at this level, since that's likeliest. */
2156 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2157 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2158 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2162 if (kid == PL_lastgotoprobe)
2164 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2166 (ops[-1]->op_type != OP_NEXTSTATE &&
2167 ops[-1]->op_type != OP_DBSTATE)))
2169 if ((o = dofindlabel(kid, label, ops, oplimit)))
2188 register PERL_CONTEXT *cx;
2189 #define GOTO_DEPTH 64
2190 OP *enterops[GOTO_DEPTH];
2192 int do_dump = (PL_op->op_type == OP_DUMP);
2193 static char must_have_label[] = "goto must have label";
2196 if (PL_op->op_flags & OPf_STACKED) {
2200 /* This egregious kludge implements goto &subroutine */
2201 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2203 register PERL_CONTEXT *cx;
2204 CV* cv = (CV*)SvRV(sv);
2210 if (!CvROOT(cv) && !CvXSUB(cv)) {
2215 /* autoloaded stub? */
2216 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2218 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2219 GvNAMELEN(gv), FALSE);
2220 if (autogv && (cv = GvCV(autogv)))
2222 tmpstr = sv_newmortal();
2223 gv_efullname3(tmpstr, gv, Nullch);
2224 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2226 DIE(aTHX_ "Goto undefined subroutine");
2229 /* First do some returnish stuff. */
2230 cxix = dopoptosub(cxstack_ix);
2232 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2233 if (cxix < cxstack_ix)
2236 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2237 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2239 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2240 /* put @_ back onto stack */
2241 AV* av = cx->blk_sub.argarray;
2243 items = AvFILLp(av) + 1;
2245 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2246 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2247 PL_stack_sp += items;
2249 SvREFCNT_dec(GvAV(PL_defgv));
2250 GvAV(PL_defgv) = cx->blk_sub.savearray;
2251 #endif /* USE_THREADS */
2252 /* abandon @_ if it got reified */
2254 (void)sv_2mortal((SV*)av); /* delay until return */
2256 av_extend(av, items-1);
2257 AvFLAGS(av) = AVf_REIFY;
2258 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2261 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2264 av = (AV*)PL_curpad[0];
2266 av = GvAV(PL_defgv);
2268 items = AvFILLp(av) + 1;
2270 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2271 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2272 PL_stack_sp += items;
2274 if (CxTYPE(cx) == CXt_SUB &&
2275 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2276 SvREFCNT_dec(cx->blk_sub.cv);
2277 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2278 LEAVE_SCOPE(oldsave);
2280 /* Now do some callish stuff. */
2283 #ifdef PERL_XSUB_OLDSTYLE
2284 if (CvOLDSTYLE(cv)) {
2285 I32 (*fp3)(int,int,int);
2290 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2291 items = (*fp3)(CvXSUBANY(cv).any_i32,
2292 mark - PL_stack_base + 1,
2294 SP = PL_stack_base + items;
2297 #endif /* PERL_XSUB_OLDSTYLE */
2302 PL_stack_sp--; /* There is no cv arg. */
2303 /* Push a mark for the start of arglist */
2305 (void)(*CvXSUB(cv))(aTHXo_ cv);
2306 /* Pop the current context like a decent sub should */
2307 POPBLOCK(cx, PL_curpm);
2308 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2311 return pop_return();
2314 AV* padlist = CvPADLIST(cv);
2315 SV** svp = AvARRAY(padlist);
2316 if (CxTYPE(cx) == CXt_EVAL) {
2317 PL_in_eval = cx->blk_eval.old_in_eval;
2318 PL_eval_root = cx->blk_eval.old_eval_root;
2319 cx->cx_type = CXt_SUB;
2320 cx->blk_sub.hasargs = 0;
2322 cx->blk_sub.cv = cv;
2323 cx->blk_sub.olddepth = CvDEPTH(cv);
2325 if (CvDEPTH(cv) < 2)
2326 (void)SvREFCNT_inc(cv);
2327 else { /* save temporaries on recursion? */
2328 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2329 sub_crush_depth(cv);
2330 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2331 AV *newpad = newAV();
2332 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2333 I32 ix = AvFILLp((AV*)svp[1]);
2334 I32 names_fill = AvFILLp((AV*)svp[0]);
2335 svp = AvARRAY(svp[0]);
2336 for ( ;ix > 0; ix--) {
2337 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2338 char *name = SvPVX(svp[ix]);
2339 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2342 /* outer lexical or anon code */
2343 av_store(newpad, ix,
2344 SvREFCNT_inc(oldpad[ix]) );
2346 else { /* our own lexical */
2348 av_store(newpad, ix, sv = (SV*)newAV());
2349 else if (*name == '%')
2350 av_store(newpad, ix, sv = (SV*)newHV());
2352 av_store(newpad, ix, sv = NEWSV(0,0));
2356 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2357 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2360 av_store(newpad, ix, sv = NEWSV(0,0));
2364 if (cx->blk_sub.hasargs) {
2367 av_store(newpad, 0, (SV*)av);
2368 AvFLAGS(av) = AVf_REIFY;
2370 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2371 AvFILLp(padlist) = CvDEPTH(cv);
2372 svp = AvARRAY(padlist);
2376 if (!cx->blk_sub.hasargs) {
2377 AV* av = (AV*)PL_curpad[0];
2379 items = AvFILLp(av) + 1;
2381 /* Mark is at the end of the stack. */
2383 Copy(AvARRAY(av), SP + 1, items, SV*);
2388 #endif /* USE_THREADS */
2389 SAVEVPTR(PL_curpad);
2390 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2392 if (cx->blk_sub.hasargs)
2393 #endif /* USE_THREADS */
2395 AV* av = (AV*)PL_curpad[0];
2399 cx->blk_sub.savearray = GvAV(PL_defgv);
2400 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2401 #endif /* USE_THREADS */
2402 cx->blk_sub.oldcurpad = PL_curpad;
2403 cx->blk_sub.argarray = av;
2406 if (items >= AvMAX(av) + 1) {
2408 if (AvARRAY(av) != ary) {
2409 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2410 SvPVX(av) = (char*)ary;
2412 if (items >= AvMAX(av) + 1) {
2413 AvMAX(av) = items - 1;
2414 Renew(ary,items+1,SV*);
2416 SvPVX(av) = (char*)ary;
2419 Copy(mark,AvARRAY(av),items,SV*);
2420 AvFILLp(av) = items - 1;
2421 assert(!AvREAL(av));
2428 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2430 * We do not care about using sv to call CV;
2431 * it's for informational purposes only.
2433 SV *sv = GvSV(PL_DBsub);
2436 if (PERLDB_SUB_NN) {
2437 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2440 gv_efullname3(sv, CvGV(cv), Nullch);
2443 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2444 PUSHMARK( PL_stack_sp );
2445 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2449 RETURNOP(CvSTART(cv));
2453 label = SvPV(sv,n_a);
2454 if (!(do_dump || *label))
2455 DIE(aTHX_ must_have_label);
2458 else if (PL_op->op_flags & OPf_SPECIAL) {
2460 DIE(aTHX_ must_have_label);
2463 label = cPVOP->op_pv;
2465 if (label && *label) {
2470 PL_lastgotoprobe = 0;
2472 for (ix = cxstack_ix; ix >= 0; ix--) {
2474 switch (CxTYPE(cx)) {
2476 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2479 gotoprobe = cx->blk_oldcop->op_sibling;
2485 gotoprobe = cx->blk_oldcop->op_sibling;
2487 gotoprobe = PL_main_root;
2490 if (CvDEPTH(cx->blk_sub.cv)) {
2491 gotoprobe = CvROOT(cx->blk_sub.cv);
2497 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2500 DIE(aTHX_ "panic: goto");
2501 gotoprobe = PL_main_root;
2505 retop = dofindlabel(gotoprobe, label,
2506 enterops, enterops + GOTO_DEPTH);
2510 PL_lastgotoprobe = gotoprobe;
2513 DIE(aTHX_ "Can't find label %s", label);
2515 /* pop unwanted frames */
2517 if (ix < cxstack_ix) {
2524 oldsave = PL_scopestack[PL_scopestack_ix];
2525 LEAVE_SCOPE(oldsave);
2528 /* push wanted frames */
2530 if (*enterops && enterops[1]) {
2532 for (ix = 1; enterops[ix]; ix++) {
2533 PL_op = enterops[ix];
2534 /* Eventually we may want to stack the needed arguments
2535 * for each op. For now, we punt on the hard ones. */
2536 if (PL_op->op_type == OP_ENTERITER)
2537 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2538 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2546 if (!retop) retop = PL_main_start;
2548 PL_restartop = retop;
2549 PL_do_undump = TRUE;
2553 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2554 PL_do_undump = FALSE;
2570 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2574 PL_exit_flags |= PERL_EXIT_EXPECTED;
2576 PUSHs(&PL_sv_undef);
2584 NV value = SvNVx(GvSV(cCOP->cop_gv));
2585 register I32 match = I_32(value);
2588 if (((NV)match) > value)
2589 --match; /* was fractional--truncate other way */
2591 match -= cCOP->uop.scop.scop_offset;
2594 else if (match > cCOP->uop.scop.scop_max)
2595 match = cCOP->uop.scop.scop_max;
2596 PL_op = cCOP->uop.scop.scop_next[match];
2606 PL_op = PL_op->op_next; /* can't assume anything */
2609 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2610 match -= cCOP->uop.scop.scop_offset;
2613 else if (match > cCOP->uop.scop.scop_max)
2614 match = cCOP->uop.scop.scop_max;
2615 PL_op = cCOP->uop.scop.scop_next[match];
2624 S_save_lines(pTHX_ AV *array, SV *sv)
2626 register char *s = SvPVX(sv);
2627 register char *send = SvPVX(sv) + SvCUR(sv);
2629 register I32 line = 1;
2631 while (s && s < send) {
2632 SV *tmpstr = NEWSV(85,0);
2634 sv_upgrade(tmpstr, SVt_PVMG);
2635 t = strchr(s, '\n');
2641 sv_setpvn(tmpstr, s, t - s);
2642 av_store(array, line++, tmpstr);
2647 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2649 S_docatch_body(pTHX_ va_list args)
2651 return docatch_body();
2656 S_docatch_body(pTHX)
2663 S_docatch(pTHX_ OP *o)
2667 volatile PERL_SI *cursi = PL_curstackinfo;
2671 assert(CATCH_GET == TRUE);
2674 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2676 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2682 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2688 if (PL_restartop && cursi == PL_curstackinfo) {
2689 PL_op = PL_restartop;
2706 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2707 /* sv Text to convert to OP tree. */
2708 /* startop op_free() this to undo. */
2709 /* code Short string id of the caller. */
2711 dSP; /* Make POPBLOCK work. */
2714 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2718 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2719 char *tmpbuf = tbuf;
2725 /* switch to eval mode */
2727 if (PL_curcop == &PL_compiling) {
2728 SAVECOPSTASH_FREE(&PL_compiling);
2729 CopSTASH_set(&PL_compiling, PL_curstash);
2731 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2732 SV *sv = sv_newmortal();
2733 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2734 code, (unsigned long)++PL_evalseq,
2735 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2739 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2740 SAVECOPFILE_FREE(&PL_compiling);
2741 CopFILE_set(&PL_compiling, tmpbuf+2);
2742 SAVECOPLINE(&PL_compiling);
2743 CopLINE_set(&PL_compiling, 1);
2744 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2745 deleting the eval's FILEGV from the stash before gv_check() runs
2746 (i.e. before run-time proper). To work around the coredump that
2747 ensues, we always turn GvMULTI_on for any globals that were
2748 introduced within evals. See force_ident(). GSAR 96-10-12 */
2749 safestr = savepv(tmpbuf);
2750 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2752 #ifdef OP_IN_REGISTER
2760 PL_op->op_type = OP_ENTEREVAL;
2761 PL_op->op_flags = 0; /* Avoid uninit warning. */
2762 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2763 PUSHEVAL(cx, 0, Nullgv);
2764 rop = doeval(G_SCALAR, startop);
2765 POPBLOCK(cx,PL_curpm);
2768 (*startop)->op_type = OP_NULL;
2769 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2771 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2773 if (PL_curcop == &PL_compiling)
2774 PL_compiling.op_private = PL_hints;
2775 #ifdef OP_IN_REGISTER
2781 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2783 S_doeval(pTHX_ int gimme, OP** startop)
2791 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2792 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2797 /* set up a scratch pad */
2800 SAVEVPTR(PL_curpad);
2801 SAVESPTR(PL_comppad);
2802 SAVESPTR(PL_comppad_name);
2803 SAVEI32(PL_comppad_name_fill);
2804 SAVEI32(PL_min_intro_pending);
2805 SAVEI32(PL_max_intro_pending);
2808 for (i = cxstack_ix - 1; i >= 0; i--) {
2809 PERL_CONTEXT *cx = &cxstack[i];
2810 if (CxTYPE(cx) == CXt_EVAL)
2812 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2813 caller = cx->blk_sub.cv;
2818 SAVESPTR(PL_compcv);
2819 PL_compcv = (CV*)NEWSV(1104,0);
2820 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2821 CvEVAL_on(PL_compcv);
2823 CvOWNER(PL_compcv) = 0;
2824 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2825 MUTEX_INIT(CvMUTEXP(PL_compcv));
2826 #endif /* USE_THREADS */
2828 PL_comppad = newAV();
2829 av_push(PL_comppad, Nullsv);
2830 PL_curpad = AvARRAY(PL_comppad);
2831 PL_comppad_name = newAV();
2832 PL_comppad_name_fill = 0;
2833 PL_min_intro_pending = 0;
2836 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2837 PL_curpad[0] = (SV*)newAV();
2838 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2839 #endif /* USE_THREADS */
2841 comppadlist = newAV();
2842 AvREAL_off(comppadlist);
2843 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2844 av_store(comppadlist, 1, (SV*)PL_comppad);
2845 CvPADLIST(PL_compcv) = comppadlist;
2848 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2850 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2853 SAVEFREESV(PL_compcv);
2855 /* make sure we compile in the right package */
2857 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2858 SAVESPTR(PL_curstash);
2859 PL_curstash = CopSTASH(PL_curcop);
2861 SAVESPTR(PL_beginav);
2862 PL_beginav = newAV();
2863 SAVEFREESV(PL_beginav);
2864 SAVEI32(PL_error_count);
2866 /* try to compile it */
2868 PL_eval_root = Nullop;
2870 PL_curcop = &PL_compiling;
2871 PL_curcop->cop_arybase = 0;
2872 SvREFCNT_dec(PL_rs);
2873 PL_rs = newSVpvn("\n", 1);
2874 if (saveop && saveop->op_flags & OPf_SPECIAL)
2875 PL_in_eval |= EVAL_KEEPERR;
2878 if (yyparse() || PL_error_count || !PL_eval_root) {
2882 I32 optype = 0; /* Might be reset by POPEVAL. */
2887 op_free(PL_eval_root);
2888 PL_eval_root = Nullop;
2890 SP = PL_stack_base + POPMARK; /* pop original mark */
2892 POPBLOCK(cx,PL_curpm);
2898 if (optype == OP_REQUIRE) {
2899 char* msg = SvPVx(ERRSV, n_a);
2900 DIE(aTHX_ "%sCompilation failed in require",
2901 *msg ? msg : "Unknown error\n");
2904 char* msg = SvPVx(ERRSV, n_a);
2906 POPBLOCK(cx,PL_curpm);
2908 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2909 (*msg ? msg : "Unknown error\n"));
2911 SvREFCNT_dec(PL_rs);
2912 PL_rs = SvREFCNT_inc(PL_nrs);
2914 MUTEX_LOCK(&PL_eval_mutex);
2916 COND_SIGNAL(&PL_eval_cond);
2917 MUTEX_UNLOCK(&PL_eval_mutex);
2918 #endif /* USE_THREADS */
2921 SvREFCNT_dec(PL_rs);
2922 PL_rs = SvREFCNT_inc(PL_nrs);
2923 CopLINE_set(&PL_compiling, 0);
2925 *startop = PL_eval_root;
2926 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2927 CvOUTSIDE(PL_compcv) = Nullcv;
2929 SAVEFREEOP(PL_eval_root);
2931 scalarvoid(PL_eval_root);
2932 else if (gimme & G_ARRAY)
2935 scalar(PL_eval_root);
2937 DEBUG_x(dump_eval());
2939 /* Register with debugger: */
2940 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2941 CV *cv = get_cv("DB::postponed", FALSE);
2945 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2947 call_sv((SV*)cv, G_DISCARD);
2951 /* compiled okay, so do it */
2953 CvDEPTH(PL_compcv) = 1;
2954 SP = PL_stack_base + POPMARK; /* pop original mark */
2955 PL_op = saveop; /* The caller may need it. */
2956 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2958 MUTEX_LOCK(&PL_eval_mutex);
2960 COND_SIGNAL(&PL_eval_cond);
2961 MUTEX_UNLOCK(&PL_eval_mutex);
2962 #endif /* USE_THREADS */
2964 RETURNOP(PL_eval_start);
2968 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2970 STRLEN namelen = strlen(name);
2973 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2974 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2975 char *pmc = SvPV_nolen(pmcsv);
2978 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2979 fp = PerlIO_open(name, mode);
2982 if (PerlLIO_stat(name, &pmstat) < 0 ||
2983 pmstat.st_mtime < pmcstat.st_mtime)
2985 fp = PerlIO_open(pmc, mode);
2988 fp = PerlIO_open(name, mode);
2991 SvREFCNT_dec(pmcsv);
2994 fp = PerlIO_open(name, mode);
3002 register PERL_CONTEXT *cx;
3007 SV *namesv = Nullsv;
3009 I32 gimme = G_SCALAR;
3010 PerlIO *tryrsfp = 0;
3012 int filter_has_file = 0;
3013 GV *filter_child_proc = 0;
3014 SV *filter_state = 0;
3019 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3020 UV rev = 0, ver = 0, sver = 0;
3022 U8 *s = (U8*)SvPVX(sv);
3023 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3025 rev = utf8_to_uv(s, end - s, &len, 0);
3028 ver = utf8_to_uv(s, end - s, &len, 0);
3031 sver = utf8_to_uv(s, end - s, &len, 0);
3034 if (PERL_REVISION < rev
3035 || (PERL_REVISION == rev
3036 && (PERL_VERSION < ver
3037 || (PERL_VERSION == ver
3038 && PERL_SUBVERSION < sver))))
3040 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3041 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3042 PERL_VERSION, PERL_SUBVERSION);
3046 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3047 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3048 + ((NV)PERL_SUBVERSION/(NV)1000000)
3049 + 0.00000099 < SvNV(sv))
3053 NV nver = (nrev - rev) * 1000;
3054 UV ver = (UV)(nver + 0.0009);
3055 NV nsver = (nver - ver) * 1000;
3056 UV sver = (UV)(nsver + 0.0009);
3058 /* help out with the "use 5.6" confusion */
3059 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3060 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3061 "this is only v%d.%d.%d, stopped"
3062 " (did you mean v%"UVuf".%"UVuf".0?)",
3063 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3064 PERL_SUBVERSION, rev, ver/100);
3067 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3068 "this is only v%d.%d.%d, stopped",
3069 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3076 name = SvPV(sv, len);
3077 if (!(name && len > 0 && *name))
3078 DIE(aTHX_ "Null filename used");
3079 TAINT_PROPER("require");
3080 if (PL_op->op_type == OP_REQUIRE &&
3081 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3082 *svp != &PL_sv_undef)
3085 /* prepare to compile file */
3087 if (PERL_FILE_IS_ABSOLUTE(name)
3088 || (*name == '.' && (name[1] == '/' ||
3089 (name[1] == '.' && name[2] == '/'))))
3092 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3093 #ifdef MACOS_TRADITIONAL
3094 /* We consider paths of the form :a:b ambiguous and interpret them first
3095 as global then as local
3097 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3106 AV *ar = GvAVn(PL_incgv);
3110 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3113 namesv = NEWSV(806, 0);
3114 for (i = 0; i <= AvFILL(ar); i++) {
3115 SV *dirsv = *av_fetch(ar, i, TRUE);
3121 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3122 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3125 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3126 PTR2UV(SvANY(loader)), name);
3127 tryname = SvPVX(namesv);
3138 count = call_sv(loader, G_ARRAY);
3148 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3152 if (SvTYPE(arg) == SVt_PVGV) {
3153 IO *io = GvIO((GV *)arg);
3158 tryrsfp = IoIFP(io);
3159 if (IoTYPE(io) == IoTYPE_PIPE) {
3160 /* reading from a child process doesn't
3161 nest -- when returning from reading
3162 the inner module, the outer one is
3163 unreadable (closed?) I've tried to
3164 save the gv to manage the lifespan of
3165 the pipe, but this didn't help. XXX */
3166 filter_child_proc = (GV *)arg;
3167 (void)SvREFCNT_inc(filter_child_proc);
3170 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3171 PerlIO_close(IoOFP(io));
3183 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3185 (void)SvREFCNT_inc(filter_sub);
3188 filter_state = SP[i];
3189 (void)SvREFCNT_inc(filter_state);
3193 tryrsfp = PerlIO_open("/dev/null",
3207 filter_has_file = 0;
3208 if (filter_child_proc) {
3209 SvREFCNT_dec(filter_child_proc);
3210 filter_child_proc = 0;
3213 SvREFCNT_dec(filter_state);
3217 SvREFCNT_dec(filter_sub);
3222 char *dir = SvPVx(dirsv, n_a);
3223 #ifdef MACOS_TRADITIONAL
3225 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3229 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3231 sv_setpv(namesv, unixdir);
3232 sv_catpv(namesv, unixname);
3234 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3237 TAINT_PROPER("require");
3238 tryname = SvPVX(namesv);
3239 #ifdef MACOS_TRADITIONAL
3241 /* Convert slashes in the name part, but not the directory part, to colons */
3243 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3247 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3249 if (tryname[0] == '.' && tryname[1] == '/')
3257 SAVECOPFILE_FREE(&PL_compiling);
3258 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3259 SvREFCNT_dec(namesv);
3261 if (PL_op->op_type == OP_REQUIRE) {
3262 char *msgstr = name;
3263 if (namesv) { /* did we lookup @INC? */
3264 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3265 SV *dirmsgsv = NEWSV(0, 0);
3266 AV *ar = GvAVn(PL_incgv);
3268 sv_catpvn(msg, " in @INC", 8);
3269 if (instr(SvPVX(msg), ".h "))
3270 sv_catpv(msg, " (change .h to .ph maybe?)");
3271 if (instr(SvPVX(msg), ".ph "))
3272 sv_catpv(msg, " (did you run h2ph?)");
3273 sv_catpv(msg, " (@INC contains:");
3274 for (i = 0; i <= AvFILL(ar); i++) {
3275 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3276 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3277 sv_catsv(msg, dirmsgsv);
3279 sv_catpvn(msg, ")", 1);
3280 SvREFCNT_dec(dirmsgsv);
3281 msgstr = SvPV_nolen(msg);
3283 DIE(aTHX_ "Can't locate %s", msgstr);
3289 SETERRNO(0, SS$_NORMAL);
3291 /* Assume success here to prevent recursive requirement. */
3292 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3293 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3297 lex_start(sv_2mortal(newSVpvn("",0)));
3298 SAVEGENERICSV(PL_rsfp_filters);
3299 PL_rsfp_filters = Nullav;
3304 SAVESPTR(PL_compiling.cop_warnings);
3305 if (PL_dowarn & G_WARN_ALL_ON)
3306 PL_compiling.cop_warnings = pWARN_ALL ;
3307 else if (PL_dowarn & G_WARN_ALL_OFF)
3308 PL_compiling.cop_warnings = pWARN_NONE ;
3310 PL_compiling.cop_warnings = pWARN_STD ;
3311 SAVESPTR(PL_compiling.cop_io);
3312 PL_compiling.cop_io = Nullsv;
3314 if (filter_sub || filter_child_proc) {
3315 SV *datasv = filter_add(run_user_filter, Nullsv);
3316 IoLINES(datasv) = filter_has_file;
3317 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3318 IoTOP_GV(datasv) = (GV *)filter_state;
3319 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3322 /* switch to eval mode */
3323 push_return(PL_op->op_next);
3324 PUSHBLOCK(cx, CXt_EVAL, SP);
3325 PUSHEVAL(cx, name, Nullgv);
3327 SAVECOPLINE(&PL_compiling);
3328 CopLINE_set(&PL_compiling, 0);
3332 MUTEX_LOCK(&PL_eval_mutex);
3333 if (PL_eval_owner && PL_eval_owner != thr)
3334 while (PL_eval_owner)
3335 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3336 PL_eval_owner = thr;
3337 MUTEX_UNLOCK(&PL_eval_mutex);
3338 #endif /* USE_THREADS */
3339 return DOCATCH(doeval(G_SCALAR, NULL));
3344 return pp_require();
3350 register PERL_CONTEXT *cx;
3352 I32 gimme = GIMME_V, was = PL_sub_generation;
3353 char tbuf[TYPE_DIGITS(long) + 12];
3354 char *tmpbuf = tbuf;
3359 if (!SvPV(sv,len) || !len)
3361 TAINT_PROPER("eval");
3367 /* switch to eval mode */
3369 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3370 SV *sv = sv_newmortal();
3371 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3372 (unsigned long)++PL_evalseq,
3373 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3377 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3378 SAVECOPFILE_FREE(&PL_compiling);
3379 CopFILE_set(&PL_compiling, tmpbuf+2);
3380 SAVECOPLINE(&PL_compiling);
3381 CopLINE_set(&PL_compiling, 1);
3382 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3383 deleting the eval's FILEGV from the stash before gv_check() runs
3384 (i.e. before run-time proper). To work around the coredump that
3385 ensues, we always turn GvMULTI_on for any globals that were
3386 introduced within evals. See force_ident(). GSAR 96-10-12 */
3387 safestr = savepv(tmpbuf);
3388 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3390 PL_hints = PL_op->op_targ;
3391 SAVESPTR(PL_compiling.cop_warnings);
3392 if (specialWARN(PL_curcop->cop_warnings))
3393 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3395 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3396 SAVEFREESV(PL_compiling.cop_warnings);
3398 SAVESPTR(PL_compiling.cop_io);
3399 if (specialCopIO(PL_curcop->cop_io))
3400 PL_compiling.cop_io = PL_curcop->cop_io;
3402 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3403 SAVEFREESV(PL_compiling.cop_io);
3406 push_return(PL_op->op_next);
3407 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3408 PUSHEVAL(cx, 0, Nullgv);
3410 /* prepare to compile string */
3412 if (PERLDB_LINE && PL_curstash != PL_debstash)
3413 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3416 MUTEX_LOCK(&PL_eval_mutex);
3417 if (PL_eval_owner && PL_eval_owner != thr)
3418 while (PL_eval_owner)
3419 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3420 PL_eval_owner = thr;
3421 MUTEX_UNLOCK(&PL_eval_mutex);
3422 #endif /* USE_THREADS */
3423 ret = doeval(gimme, NULL);
3424 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3425 && ret != PL_op->op_next) { /* Successive compilation. */
3426 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3428 return DOCATCH(ret);
3438 register PERL_CONTEXT *cx;
3440 U8 save_flags = PL_op -> op_flags;
3445 retop = pop_return();
3448 if (gimme == G_VOID)
3450 else if (gimme == G_SCALAR) {
3453 if (SvFLAGS(TOPs) & SVs_TEMP)
3456 *MARK = sv_mortalcopy(TOPs);
3460 *MARK = &PL_sv_undef;
3465 /* in case LEAVE wipes old return values */
3466 for (mark = newsp + 1; mark <= SP; mark++) {
3467 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3468 *mark = sv_mortalcopy(*mark);
3469 TAINT_NOT; /* Each item is independent */
3473 PL_curpm = newpm; /* Don't pop $1 et al till now */
3475 if (AvFILLp(PL_comppad_name) >= 0)
3479 assert(CvDEPTH(PL_compcv) == 1);
3481 CvDEPTH(PL_compcv) = 0;
3484 if (optype == OP_REQUIRE &&
3485 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3487 /* Unassume the success we assumed earlier. */
3488 SV *nsv = cx->blk_eval.old_namesv;
3489 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3490 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3491 /* die_where() did LEAVE, or we won't be here */
3495 if (!(save_flags & OPf_SPECIAL))
3505 register PERL_CONTEXT *cx;
3506 I32 gimme = GIMME_V;
3511 push_return(cLOGOP->op_other->op_next);
3512 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3514 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3516 PL_in_eval = EVAL_INEVAL;
3519 return DOCATCH(PL_op->op_next);
3529 register PERL_CONTEXT *cx;
3537 if (gimme == G_VOID)
3539 else if (gimme == G_SCALAR) {
3542 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3545 *MARK = sv_mortalcopy(TOPs);
3549 *MARK = &PL_sv_undef;
3554 /* in case LEAVE wipes old return values */
3555 for (mark = newsp + 1; mark <= SP; mark++) {
3556 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3557 *mark = sv_mortalcopy(*mark);
3558 TAINT_NOT; /* Each item is independent */
3562 PL_curpm = newpm; /* Don't pop $1 et al till now */
3570 S_doparseform(pTHX_ SV *sv)
3573 register char *s = SvPV_force(sv, len);
3574 register char *send = s + len;
3575 register char *base;
3576 register I32 skipspaces = 0;
3579 bool postspace = FALSE;
3587 Perl_croak(aTHX_ "Null picture in formline");
3589 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3594 *fpc++ = FF_LINEMARK;
3595 noblank = repeat = FALSE;
3613 case ' ': case '\t':
3624 *fpc++ = FF_LITERAL;
3632 *fpc++ = skipspaces;
3636 *fpc++ = FF_NEWLINE;
3640 arg = fpc - linepc + 1;
3647 *fpc++ = FF_LINEMARK;
3648 noblank = repeat = FALSE;
3657 ischop = s[-1] == '^';
3663 arg = (s - base) - 1;
3665 *fpc++ = FF_LITERAL;
3674 *fpc++ = FF_LINEGLOB;
3676 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3677 arg = ischop ? 512 : 0;
3687 arg |= 256 + (s - f);
3689 *fpc++ = s - base; /* fieldsize for FETCH */
3690 *fpc++ = FF_DECIMAL;
3693 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3694 arg = ischop ? 512 : 0;
3696 s++; /* skip the '0' first */
3705 arg |= 256 + (s - f);
3707 *fpc++ = s - base; /* fieldsize for FETCH */
3708 *fpc++ = FF_0DECIMAL;
3713 bool ismore = FALSE;
3716 while (*++s == '>') ;
3717 prespace = FF_SPACE;
3719 else if (*s == '|') {
3720 while (*++s == '|') ;
3721 prespace = FF_HALFSPACE;
3726 while (*++s == '<') ;
3729 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3733 *fpc++ = s - base; /* fieldsize for FETCH */
3735 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3753 { /* need to jump to the next word */
3755 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3756 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3757 s = SvPVX(sv) + SvCUR(sv) + z;
3759 Copy(fops, s, arg, U16);
3761 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3766 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3768 * The original code was written in conjunction with BSD Computer Software
3769 * Research Group at University of California, Berkeley.
3771 * See also: "Optimistic Merge Sort" (SODA '92)
3773 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3775 * The code can be distributed under the same terms as Perl itself.
3780 #include <sys/types.h>
3785 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3786 #define Safefree(VAR) free(VAR)
3787 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3788 #endif /* TESTHARNESS */
3790 typedef char * aptr; /* pointer for arithmetic on sizes */
3791 typedef SV * gptr; /* pointers in our lists */
3793 /* Binary merge internal sort, with a few special mods
3794 ** for the special perl environment it now finds itself in.
3796 ** Things that were once options have been hotwired
3797 ** to values suitable for this use. In particular, we'll always
3798 ** initialize looking for natural runs, we'll always produce stable
3799 ** output, and we'll always do Peter McIlroy's binary merge.
3802 /* Pointer types for arithmetic and storage and convenience casts */
3804 #define APTR(P) ((aptr)(P))
3805 #define GPTP(P) ((gptr *)(P))
3806 #define GPPP(P) ((gptr **)(P))
3809 /* byte offset from pointer P to (larger) pointer Q */
3810 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3812 #define PSIZE sizeof(gptr)
3814 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3817 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3818 #define PNBYTE(N) ((N) << (PSHIFT))
3819 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3821 /* Leave optimization to compiler */
3822 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3823 #define PNBYTE(N) ((N) * (PSIZE))
3824 #define PINDEX(P, N) (GPTP(P) + (N))
3827 /* Pointer into other corresponding to pointer into this */
3828 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3830 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3833 /* Runs are identified by a pointer in the auxilliary list.
3834 ** The pointer is at the start of the list,
3835 ** and it points to the start of the next list.
3836 ** NEXT is used as an lvalue, too.
3839 #define NEXT(P) (*GPPP(P))
3842 /* PTHRESH is the minimum number of pairs with the same sense to justify
3843 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3844 ** not just elements, so PTHRESH == 8 means a run of 16.
3849 /* RTHRESH is the number of elements in a run that must compare low
3850 ** to the low element from the opposing run before we justify
3851 ** doing a binary rampup instead of single stepping.
3852 ** In random input, N in a row low should only happen with
3853 ** probability 2^(1-N), so we can risk that we are dealing
3854 ** with orderly input without paying much when we aren't.
3861 ** Overview of algorithm and variables.
3862 ** The array of elements at list1 will be organized into runs of length 2,
3863 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3864 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3866 ** Unless otherwise specified, pair pointers address the first of two elements.
3868 ** b and b+1 are a pair that compare with sense ``sense''.
3869 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3871 ** p2 parallels b in the list2 array, where runs are defined by
3874 ** t represents the ``top'' of the adjacent pairs that might extend
3875 ** the run beginning at b. Usually, t addresses a pair
3876 ** that compares with opposite sense from (b,b+1).
3877 ** However, it may also address a singleton element at the end of list1,
3878 ** or it may be equal to ``last'', the first element beyond list1.
3880 ** r addresses the Nth pair following b. If this would be beyond t,
3881 ** we back it off to t. Only when r is less than t do we consider the
3882 ** run long enough to consider checking.
3884 ** q addresses a pair such that the pairs at b through q already form a run.
3885 ** Often, q will equal b, indicating we only are sure of the pair itself.
3886 ** However, a search on the previous cycle may have revealed a longer run,
3887 ** so q may be greater than b.
3889 ** p is used to work back from a candidate r, trying to reach q,
3890 ** which would mean b through r would be a run. If we discover such a run,
3891 ** we start q at r and try to push it further towards t.
3892 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3893 ** In any event, after the check (if any), we have two main cases.
3895 ** 1) Short run. b <= q < p <= r <= t.
3896 ** b through q is a run (perhaps trivial)
3897 ** q through p are uninteresting pairs
3898 ** p through r is a run
3900 ** 2) Long run. b < r <= q < t.
3901 ** b through q is a run (of length >= 2 * PTHRESH)
3903 ** Note that degenerate cases are not only possible, but likely.
3904 ** For example, if the pair following b compares with opposite sense,
3905 ** then b == q < p == r == t.
3910 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3913 register gptr *b, *p, *q, *t, *p2;
3914 register gptr c, *last, *r;
3918 last = PINDEX(b, nmemb);
3919 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3920 for (p2 = list2; b < last; ) {
3921 /* We just started, or just reversed sense.
3922 ** Set t at end of pairs with the prevailing sense.
3924 for (p = b+2, t = p; ++p < last; t = ++p) {
3925 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3928 /* Having laid out the playing field, look for long runs */
3930 p = r = b + (2 * PTHRESH);
3931 if (r >= t) p = r = t; /* too short to care about */
3933 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3936 /* b through r is a (long) run.
3937 ** Extend it as far as possible.
3940 while (((p += 2) < t) &&
3941 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3942 r = p = q + 2; /* no simple pairs, no after-run */
3945 if (q > b) { /* run of greater than 2 at b */
3948 /* pick up singleton, if possible */
3950 ((t + 1) == last) &&
3951 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3952 savep = r = p = q = last;
3953 p2 = NEXT(p2) = p2 + (p - b);
3954 if (sense) while (b < --p) {
3961 while (q < p) { /* simple pairs */
3962 p2 = NEXT(p2) = p2 + 2;
3969 if (((b = p) == t) && ((t+1) == last)) {
3981 /* Overview of bmerge variables:
3983 ** list1 and list2 address the main and auxiliary arrays.
3984 ** They swap identities after each merge pass.
3985 ** Base points to the original list1, so we can tell if
3986 ** the pointers ended up where they belonged (or must be copied).
3988 ** When we are merging two lists, f1 and f2 are the next elements
3989 ** on the respective lists. l1 and l2 mark the end of the lists.
3990 ** tp2 is the current location in the merged list.
3992 ** p1 records where f1 started.
3993 ** After the merge, a new descriptor is built there.
3995 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3996 ** It is used to identify and delimit the runs.
3998 ** In the heat of determining where q, the greater of the f1/f2 elements,
3999 ** belongs in the other list, b, t and p, represent bottom, top and probe
4000 ** locations, respectively, in the other list.
4001 ** They make convenient temporary pointers in other places.
4005 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4009 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4010 gptr *aux, *list2, *p2, *last;
4014 if (nmemb <= 1) return; /* sorted trivially */
4015 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4017 dynprep(aTHX_ list1, list2, nmemb, cmp);
4018 last = PINDEX(list2, nmemb);
4019 while (NEXT(list2) != last) {
4020 /* More than one run remains. Do some merging to reduce runs. */
4022 for (tp2 = p2 = list2; p2 != last;) {
4023 /* The new first run begins where the old second list ended.
4024 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4028 f2 = l1 = POTHER(t, list2, list1);
4029 if (t != last) t = NEXT(t);
4030 l2 = POTHER(t, list2, list1);
4032 while (f1 < l1 && f2 < l2) {
4033 /* If head 1 is larger than head 2, find ALL the elements
4034 ** in list 2 strictly less than head1, write them all,
4035 ** then head 1. Then compare the new heads, and repeat,
4036 ** until one or both lists are exhausted.
4038 ** In all comparisons (after establishing
4039 ** which head to merge) the item to merge
4040 ** (at pointer q) is the first operand of
4041 ** the comparison. When we want to know
4042 ** if ``q is strictly less than the other'',
4044 ** cmp(q, other) < 0
4045 ** because stability demands that we treat equality
4046 ** as high when q comes from l2, and as low when
4047 ** q was from l1. So we ask the question by doing
4048 ** cmp(q, other) <= sense
4049 ** and make sense == 0 when equality should look low,
4050 ** and -1 when equality should look high.
4054 if (cmp(aTHX_ *f1, *f2) <= 0) {
4055 q = f2; b = f1; t = l1;
4058 q = f1; b = f2; t = l2;
4065 ** Leave t at something strictly
4066 ** greater than q (or at the end of the list),
4067 ** and b at something strictly less than q.
4069 for (i = 1, run = 0 ;;) {
4070 if ((p = PINDEX(b, i)) >= t) {
4072 if (((p = PINDEX(t, -1)) > b) &&
4073 (cmp(aTHX_ *q, *p) <= sense))
4077 } else if (cmp(aTHX_ *q, *p) <= sense) {
4081 if (++run >= RTHRESH) i += i;
4085 /* q is known to follow b and must be inserted before t.
4086 ** Increment b, so the range of possibilities is [b,t).
4087 ** Round binary split down, to favor early appearance.
4088 ** Adjust b and t until q belongs just before t.
4093 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4094 if (cmp(aTHX_ *q, *p) <= sense) {
4100 /* Copy all the strictly low elements */
4103 FROMTOUPTO(f2, tp2, t);
4106 FROMTOUPTO(f1, tp2, t);
4112 /* Run out remaining list */
4114 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4115 } else FROMTOUPTO(f1, tp2, l1);
4116 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4121 last = PINDEX(list2, nmemb);
4123 if (base == list2) {
4124 last = PINDEX(list1, nmemb);
4125 FROMTOUPTO(list1, list2, last);
4140 sortcv(pTHXo_ SV *a, SV *b)
4142 I32 oldsaveix = PL_savestack_ix;
4143 I32 oldscopeix = PL_scopestack_ix;
4145 GvSV(PL_firstgv) = a;
4146 GvSV(PL_secondgv) = b;
4147 PL_stack_sp = PL_stack_base;
4150 if (PL_stack_sp != PL_stack_base + 1)
4151 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4152 if (!SvNIOKp(*PL_stack_sp))
4153 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4154 result = SvIV(*PL_stack_sp);
4155 while (PL_scopestack_ix > oldscopeix) {
4158 leave_scope(oldsaveix);
4163 sortcv_stacked(pTHXo_ SV *a, SV *b)
4165 I32 oldsaveix = PL_savestack_ix;
4166 I32 oldscopeix = PL_scopestack_ix;
4171 av = (AV*)PL_curpad[0];
4173 av = GvAV(PL_defgv);
4176 if (AvMAX(av) < 1) {
4177 SV** ary = AvALLOC(av);
4178 if (AvARRAY(av) != ary) {
4179 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4180 SvPVX(av) = (char*)ary;
4182 if (AvMAX(av) < 1) {
4185 SvPVX(av) = (char*)ary;
4192 PL_stack_sp = PL_stack_base;
4195 if (PL_stack_sp != PL_stack_base + 1)
4196 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4197 if (!SvNIOKp(*PL_stack_sp))
4198 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4199 result = SvIV(*PL_stack_sp);
4200 while (PL_scopestack_ix > oldscopeix) {
4203 leave_scope(oldsaveix);
4208 sortcv_xsub(pTHXo_ SV *a, SV *b)
4211 I32 oldsaveix = PL_savestack_ix;
4212 I32 oldscopeix = PL_scopestack_ix;
4214 CV *cv=(CV*)PL_sortcop;
4222 (void)(*CvXSUB(cv))(aTHXo_ cv);
4223 if (PL_stack_sp != PL_stack_base + 1)
4224 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4225 if (!SvNIOKp(*PL_stack_sp))
4226 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4227 result = SvIV(*PL_stack_sp);
4228 while (PL_scopestack_ix > oldscopeix) {
4231 leave_scope(oldsaveix);
4237 sv_ncmp(pTHXo_ SV *a, SV *b)
4241 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4245 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4249 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4251 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4253 if (PL_amagic_generation) { \
4254 if (SvAMAGIC(left)||SvAMAGIC(right))\
4255 *svp = amagic_call(left, \
4263 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4266 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4271 I32 i = SvIVX(tmpsv);
4281 return sv_ncmp(aTHXo_ a, b);
4285 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4288 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4293 I32 i = SvIVX(tmpsv);
4303 return sv_i_ncmp(aTHXo_ a, b);
4307 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4310 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4315 I32 i = SvIVX(tmpsv);
4325 return sv_cmp(str1, str2);
4329 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4332 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4337 I32 i = SvIVX(tmpsv);
4347 return sv_cmp_locale(str1, str2);
4351 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4353 SV *datasv = FILTER_DATA(idx);
4354 int filter_has_file = IoLINES(datasv);
4355 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4356 SV *filter_state = (SV *)IoTOP_GV(datasv);
4357 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4360 /* I was having segfault trouble under Linux 2.2.5 after a
4361 parse error occured. (Had to hack around it with a test
4362 for PL_error_count == 0.) Solaris doesn't segfault --
4363 not sure where the trouble is yet. XXX */
4365 if (filter_has_file) {
4366 len = FILTER_READ(idx+1, buf_sv, maxlen);
4369 if (filter_sub && len >= 0) {
4380 PUSHs(sv_2mortal(newSViv(maxlen)));
4382 PUSHs(filter_state);
4385 count = call_sv(filter_sub, G_SCALAR);
4401 IoLINES(datasv) = 0;
4402 if (filter_child_proc) {
4403 SvREFCNT_dec(filter_child_proc);
4404 IoFMT_GV(datasv) = Nullgv;
4407 SvREFCNT_dec(filter_state);
4408 IoTOP_GV(datasv) = Nullgv;
4411 SvREFCNT_dec(filter_sub);
4412 IoBOTTOM_GV(datasv) = Nullgv;
4414 filter_del(run_user_filter);
4423 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4425 return sv_cmp_locale(str1, str2);
4429 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4431 return sv_cmp(str1, str2);
4434 #endif /* PERL_OBJECT */