3 * Copyright (c) 1991-2001, 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(pTHX_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHX_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHX_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHX_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHX_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHX_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHX_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHX_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHX_ SV *a, SV *b);
38 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
40 #define sv_cmp_static Perl_sv_cmp
41 #define sv_cmp_locale_static Perl_sv_cmp_locale
49 cxix = dopoptosub(cxstack_ix);
53 switch (cxstack[cxix].blk_gimme) {
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
79 register PMOP *pm = (PMOP*)cLOGOP->op_other;
83 MAGIC *mg = Null(MAGIC*);
87 /* prevent recompiling under /o and ithreads. */
88 #if defined(USE_ITHREADS) || defined(USE_5005THREADS)
89 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
94 SV *sv = SvRV(tmpstr);
96 mg = mg_find(sv, PERL_MAGIC_qr);
99 regexp *re = (regexp *)mg->mg_obj;
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, ReREFCNT_inc(re));
104 t = SvPV(tmpstr, len);
106 /* Check against the last compiled regexp. */
107 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
108 PM_GETRE(pm)->prelen != len ||
109 memNE(PM_GETRE(pm)->precomp, t, len))
112 ReREFCNT_dec(PM_GETRE(pm));
113 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
115 if (PL_op->op_flags & OPf_SPECIAL)
116 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
118 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
120 pm->op_pmdynflags |= PMdf_DYN_UTF8;
122 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
123 if (pm->op_pmdynflags & PMdf_UTF8)
124 t = (char*)bytes_to_utf8((U8*)t, &len);
126 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
127 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
129 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
130 inside tie/overload accessors. */
134 #ifndef INCOMPLETE_TAINTS
137 pm->op_pmdynflags |= PMdf_TAINTED;
139 pm->op_pmdynflags &= ~PMdf_TAINTED;
143 if (!PM_GETRE(pm)->prelen && PL_curpm)
145 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
146 pm->op_pmflags |= PMf_WHITE;
148 pm->op_pmflags &= ~PMf_WHITE;
150 /* XXX runtime compiled output needs to move to the pad */
151 if (pm->op_pmflags & PMf_KEEP) {
152 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
153 #if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
154 /* XXX can't change the optree at runtime either */
155 cLOGOP->op_first->op_next = PL_op->op_next;
164 register PMOP *pm = (PMOP*) cLOGOP->op_other;
165 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
166 register SV *dstr = cx->sb_dstr;
167 register char *s = cx->sb_s;
168 register char *m = cx->sb_m;
169 char *orig = cx->sb_orig;
170 register REGEXP *rx = cx->sb_rx;
172 rxres_restore(&cx->sb_rxres, rx);
174 if (cx->sb_iters++) {
175 I32 saviters = cx->sb_iters;
176 if (cx->sb_iters > cx->sb_maxiters)
177 DIE(aTHX_ "Substitution loop");
179 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
180 cx->sb_rxtainted |= 2;
181 sv_catsv(dstr, POPs);
184 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
185 s == m, cx->sb_targ, NULL,
186 ((cx->sb_rflags & REXEC_COPY_STR)
187 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
188 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
190 SV *targ = cx->sb_targ;
192 sv_catpvn(dstr, s, cx->sb_strend - s);
193 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
195 (void)SvOOK_off(targ);
196 Safefree(SvPVX(targ));
197 SvPVX(targ) = SvPVX(dstr);
198 SvCUR_set(targ, SvCUR(dstr));
199 SvLEN_set(targ, SvLEN(dstr));
205 TAINT_IF(cx->sb_rxtainted & 1);
206 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
208 (void)SvPOK_only_UTF8(targ);
209 TAINT_IF(cx->sb_rxtainted);
213 LEAVE_SCOPE(cx->sb_oldsave);
215 RETURNOP(pm->op_next);
217 cx->sb_iters = saviters;
219 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
222 cx->sb_orig = orig = rx->subbeg;
224 cx->sb_strend = s + (cx->sb_strend - m);
226 cx->sb_m = m = rx->startp[0] + orig;
228 sv_catpvn(dstr, s, m-s);
229 cx->sb_s = rx->endp[0] + orig;
230 { /* Update the pos() information. */
231 SV *sv = cx->sb_targ;
234 if (SvTYPE(sv) < SVt_PVMG)
235 (void)SvUPGRADE(sv, SVt_PVMG);
236 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
237 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
238 mg = mg_find(sv, PERL_MAGIC_regex_global);
245 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
246 rxres_save(&cx->sb_rxres, rx);
247 RETURNOP(pm->op_pmreplstart);
251 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
256 if (!p || p[1] < rx->nparens) {
257 i = 6 + rx->nparens * 2;
265 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
266 RX_MATCH_COPIED_off(rx);
270 *p++ = PTR2UV(rx->subbeg);
271 *p++ = (UV)rx->sublen;
272 for (i = 0; i <= rx->nparens; ++i) {
273 *p++ = (UV)rx->startp[i];
274 *p++ = (UV)rx->endp[i];
279 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
284 if (RX_MATCH_COPIED(rx))
285 Safefree(rx->subbeg);
286 RX_MATCH_COPIED_set(rx, *p);
291 rx->subbeg = INT2PTR(char*,*p++);
292 rx->sublen = (I32)(*p++);
293 for (i = 0; i <= rx->nparens; ++i) {
294 rx->startp[i] = (I32)(*p++);
295 rx->endp[i] = (I32)(*p++);
300 Perl_rxres_free(pTHX_ void **rsp)
305 Safefree(INT2PTR(char*,*p));
313 dSP; dMARK; dORIGMARK;
314 register SV *tmpForm = *++MARK;
321 register SV *sv = Nullsv;
326 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
327 char *chophere = Nullch;
328 char *linemark = Nullch;
330 bool gotsome = FALSE;
332 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
333 bool item_is_utf = FALSE;
335 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
336 if (SvREADONLY(tmpForm)) {
337 SvREADONLY_off(tmpForm);
338 doparseform(tmpForm);
339 SvREADONLY_on(tmpForm);
342 doparseform(tmpForm);
345 SvPV_force(PL_formtarget, len);
346 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
348 f = SvPV(tmpForm, len);
349 /* need to jump to the next word */
350 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
359 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
360 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
361 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
362 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
363 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
365 case FF_CHECKNL: name = "CHECKNL"; break;
366 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
367 case FF_SPACE: name = "SPACE"; break;
368 case FF_HALFSPACE: name = "HALFSPACE"; break;
369 case FF_ITEM: name = "ITEM"; break;
370 case FF_CHOP: name = "CHOP"; break;
371 case FF_LINEGLOB: name = "LINEGLOB"; break;
372 case FF_NEWLINE: name = "NEWLINE"; break;
373 case FF_MORE: name = "MORE"; break;
374 case FF_LINEMARK: name = "LINEMARK"; break;
375 case FF_END: name = "END"; break;
376 case FF_0DECIMAL: name = "0DECIMAL"; break;
379 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
381 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
409 if (ckWARN(WARN_SYNTAX))
410 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
415 item = s = SvPV(sv, len);
418 itemsize = sv_len_utf8(sv);
419 if (itemsize != len) {
421 if (itemsize > fieldsize) {
422 itemsize = fieldsize;
423 itembytes = itemsize;
424 sv_pos_u2b(sv, &itembytes, 0);
428 send = chophere = s + itembytes;
438 sv_pos_b2u(sv, &itemsize);
443 if (itemsize > fieldsize)
444 itemsize = fieldsize;
445 send = chophere = s + itemsize;
457 item = s = SvPV(sv, len);
460 itemsize = sv_len_utf8(sv);
461 if (itemsize != len) {
463 if (itemsize <= fieldsize) {
464 send = chophere = s + itemsize;
475 itemsize = fieldsize;
476 itembytes = itemsize;
477 sv_pos_u2b(sv, &itembytes, 0);
478 send = chophere = s + itembytes;
479 while (s < send || (s == send && isSPACE(*s))) {
489 if (strchr(PL_chopset, *s))
494 itemsize = chophere - item;
495 sv_pos_b2u(sv, &itemsize);
502 if (itemsize <= fieldsize) {
503 send = chophere = s + itemsize;
514 itemsize = fieldsize;
515 send = chophere = s + itemsize;
516 while (s < send || (s == send && isSPACE(*s))) {
526 if (strchr(PL_chopset, *s))
531 itemsize = chophere - item;
536 arg = fieldsize - itemsize;
545 arg = fieldsize - itemsize;
559 if (UTF8_IS_CONTINUED(*s)) {
560 STRLEN skip = UTF8SKIP(s);
577 if ( !((*t++ = *s++) & ~31) )
585 int ch = *t++ = *s++;
588 if ( !((*t++ = *s++) & ~31) )
597 while (*s && isSPACE(*s))
604 item = s = SvPV(sv, len);
606 item_is_utf = FALSE; /* XXX is this correct? */
618 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
619 sv_catpvn(PL_formtarget, item, itemsize);
620 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
621 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
626 /* If the field is marked with ^ and the value is undefined,
629 if ((arg & 512) && !SvOK(sv)) {
637 /* Formats aren't yet marked for locales, so assume "yes". */
639 STORE_NUMERIC_STANDARD_SET_LOCAL();
640 #if defined(USE_LONG_DOUBLE)
642 sprintf(t, "%#*.*" PERL_PRIfldbl,
643 (int) fieldsize, (int) arg & 255, value);
645 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
650 (int) fieldsize, (int) arg & 255, value);
653 (int) fieldsize, value);
656 RESTORE_NUMERIC_STANDARD();
662 /* If the field is marked with ^ and the value is undefined,
665 if ((arg & 512) && !SvOK(sv)) {
673 /* Formats aren't yet marked for locales, so assume "yes". */
675 STORE_NUMERIC_STANDARD_SET_LOCAL();
676 #if defined(USE_LONG_DOUBLE)
678 sprintf(t, "%#0*.*" PERL_PRIfldbl,
679 (int) fieldsize, (int) arg & 255, value);
680 /* is this legal? I don't have long doubles */
682 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
686 sprintf(t, "%#0*.*f",
687 (int) fieldsize, (int) arg & 255, value);
690 (int) fieldsize, value);
693 RESTORE_NUMERIC_STANDARD();
700 while (t-- > linemark && *t == ' ') ;
708 if (arg) { /* repeat until fields exhausted? */
710 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
711 lines += FmLINES(PL_formtarget);
714 if (strnEQ(linemark, linemark - arg, arg))
715 DIE(aTHX_ "Runaway format");
717 FmLINES(PL_formtarget) = lines;
719 RETURNOP(cLISTOP->op_first);
732 while (*s && isSPACE(*s) && s < send)
736 arg = fieldsize - itemsize;
743 if (strnEQ(s," ",3)) {
744 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
755 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
756 FmLINES(PL_formtarget) += lines;
768 if (PL_stack_base + *PL_markstack_ptr == SP) {
770 if (GIMME_V == G_SCALAR)
771 XPUSHs(sv_2mortal(newSViv(0)));
772 RETURNOP(PL_op->op_next->op_next);
774 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
775 pp_pushmark(); /* push dst */
776 pp_pushmark(); /* push src */
777 ENTER; /* enter outer scope */
780 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
782 ENTER; /* enter inner scope */
785 src = PL_stack_base[*PL_markstack_ptr];
790 if (PL_op->op_type == OP_MAPSTART)
791 pp_pushmark(); /* push top */
792 return ((LOGOP*)PL_op->op_next)->op_other;
797 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
803 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
809 /* first, move source pointer to the next item in the source list */
810 ++PL_markstack_ptr[-1];
812 /* if there are new items, push them into the destination list */
814 /* might need to make room back there first */
815 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
816 /* XXX this implementation is very pessimal because the stack
817 * is repeatedly extended for every set of items. Is possible
818 * to do this without any stack extension or copying at all
819 * by maintaining a separate list over which the map iterates
820 * (like foreach does). --gsar */
822 /* everything in the stack after the destination list moves
823 * towards the end the stack by the amount of room needed */
824 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
826 /* items to shift up (accounting for the moved source pointer) */
827 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
829 /* This optimization is by Ben Tilly and it does
830 * things differently from what Sarathy (gsar)
831 * is describing. The downside of this optimization is
832 * that leaves "holes" (uninitialized and hopefully unused areas)
833 * to the Perl stack, but on the other hand this
834 * shouldn't be a problem. If Sarathy's idea gets
835 * implemented, this optimization should become
836 * irrelevant. --jhi */
838 shift = count; /* Avoid shifting too often --Ben Tilly */
843 PL_markstack_ptr[-1] += shift;
844 *PL_markstack_ptr += shift;
848 /* copy the new items down to the destination list */
849 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
851 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
853 LEAVE; /* exit inner scope */
856 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
859 (void)POPMARK; /* pop top */
860 LEAVE; /* exit outer scope */
861 (void)POPMARK; /* pop src */
862 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
863 (void)POPMARK; /* pop dst */
864 SP = PL_stack_base + POPMARK; /* pop original mark */
865 if (gimme == G_SCALAR) {
869 else if (gimme == G_ARRAY)
876 ENTER; /* enter inner scope */
879 /* set $_ to the new source item */
880 src = PL_stack_base[PL_markstack_ptr[-1]];
884 RETURNOP(cLOGOP->op_other);
890 dSP; dMARK; dORIGMARK;
892 SV **myorigmark = ORIGMARK;
898 OP* nextop = PL_op->op_next;
900 bool hasargs = FALSE;
903 if (gimme != G_ARRAY) {
909 SAVEVPTR(PL_sortcop);
910 if (PL_op->op_flags & OPf_STACKED) {
911 if (PL_op->op_flags & OPf_SPECIAL) {
912 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
913 kid = kUNOP->op_first; /* pass rv2gv */
914 kid = kUNOP->op_first; /* pass leave */
915 PL_sortcop = kid->op_next;
916 stash = CopSTASH(PL_curcop);
919 cv = sv_2cv(*++MARK, &stash, &gv, 0);
920 if (cv && SvPOK(cv)) {
922 char *proto = SvPV((SV*)cv, n_a);
923 if (proto && strEQ(proto, "$$")) {
927 if (!(cv && CvROOT(cv))) {
928 if (cv && CvXSUB(cv)) {
932 SV *tmpstr = sv_newmortal();
933 gv_efullname3(tmpstr, gv, Nullch);
934 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
938 DIE(aTHX_ "Undefined subroutine in sort");
943 PL_sortcop = (OP*)cv;
945 PL_sortcop = CvSTART(cv);
946 SAVEVPTR(CvROOT(cv)->op_ppaddr);
947 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
950 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
956 stash = CopSTASH(PL_curcop);
960 while (MARK < SP) { /* This may or may not shift down one here. */
962 if ((*up = *++MARK)) { /* Weed out nulls. */
964 if (!PL_sortcop && !SvPOK(*up)) {
969 (void)sv_2pv(*up, &n_a);
974 max = --up - myorigmark;
979 bool oldcatch = CATCH_GET;
985 PUSHSTACKi(PERLSI_SORT);
986 if (!hasargs && !is_xsub) {
987 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
988 SAVESPTR(PL_firstgv);
989 SAVESPTR(PL_secondgv);
990 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
991 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
992 PL_sortstash = stash;
994 #ifdef USE_5005THREADS
995 sv_lock((SV *)PL_firstgv);
996 sv_lock((SV *)PL_secondgv);
998 SAVESPTR(GvSV(PL_firstgv));
999 SAVESPTR(GvSV(PL_secondgv));
1002 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1003 if (!(PL_op->op_flags & OPf_SPECIAL)) {
1004 cx->cx_type = CXt_SUB;
1005 cx->blk_gimme = G_SCALAR;
1008 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1010 PL_sortcxix = cxstack_ix;
1012 if (hasargs && !is_xsub) {
1013 /* This is mostly copied from pp_entersub */
1014 AV *av = (AV*)PL_curpad[0];
1016 #ifndef USE_5005THREADS
1017 cx->blk_sub.savearray = GvAV(PL_defgv);
1018 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1019 #endif /* USE_5005THREADS */
1020 cx->blk_sub.oldcurpad = PL_curpad;
1021 cx->blk_sub.argarray = av;
1023 sortsv((myorigmark+1), max,
1024 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1026 POPBLOCK(cx,PL_curpm);
1027 PL_stack_sp = newsp;
1029 CATCH_SET(oldcatch);
1034 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1035 sortsv(ORIGMARK+1, max,
1036 (PL_op->op_private & OPpSORT_NUMERIC)
1037 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1038 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1039 : ( overloading ? amagic_ncmp : sv_ncmp))
1040 : ( IN_LOCALE_RUNTIME
1043 : sv_cmp_locale_static)
1044 : ( overloading ? amagic_cmp : sv_cmp_static)));
1045 if (PL_op->op_private & OPpSORT_REVERSE) {
1046 SV **p = ORIGMARK+1;
1047 SV **q = ORIGMARK+max;
1057 PL_stack_sp = ORIGMARK + max;
1065 if (GIMME == G_ARRAY)
1067 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1068 return cLOGOP->op_other;
1077 if (GIMME == G_ARRAY) {
1078 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1082 SV *targ = PAD_SV(PL_op->op_targ);
1085 if (PL_op->op_private & OPpFLIP_LINENUM) {
1087 flip = PL_last_in_gv
1088 && (gp_io = GvIO(PL_last_in_gv))
1089 && SvIV(sv) == (IV)IoLINES(gp_io);
1094 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1095 if (PL_op->op_flags & OPf_SPECIAL) {
1103 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1116 if (GIMME == G_ARRAY) {
1122 if (SvGMAGICAL(left))
1124 if (SvGMAGICAL(right))
1127 if (SvNIOKp(left) || !SvPOKp(left) ||
1128 SvNIOKp(right) || !SvPOKp(right) ||
1129 (looks_like_number(left) && *SvPVX(left) != '0' &&
1130 looks_like_number(right) && *SvPVX(right) != '0'))
1132 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1133 DIE(aTHX_ "Range iterator outside integer range");
1144 sv = sv_2mortal(newSViv(i++));
1149 SV *final = sv_mortalcopy(right);
1151 char *tmps = SvPV(final, len);
1153 sv = sv_mortalcopy(left);
1155 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1157 if (strEQ(SvPVX(sv),tmps))
1159 sv = sv_2mortal(newSVsv(sv));
1166 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1168 if ((PL_op->op_private & OPpFLIP_LINENUM)
1169 ? (GvIO(PL_last_in_gv)
1170 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1172 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1173 sv_catpv(targ, "E0");
1184 S_dopoptolabel(pTHX_ char *label)
1187 register PERL_CONTEXT *cx;
1189 for (i = cxstack_ix; i >= 0; i--) {
1191 switch (CxTYPE(cx)) {
1193 if (ckWARN(WARN_EXITING))
1194 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1198 if (ckWARN(WARN_EXITING))
1199 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1203 if (ckWARN(WARN_EXITING))
1204 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1208 if (ckWARN(WARN_EXITING))
1209 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1213 if (ckWARN(WARN_EXITING))
1214 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1218 if (!cx->blk_loop.label ||
1219 strNE(label, cx->blk_loop.label) ) {
1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1221 (long)i, cx->blk_loop.label));
1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1232 Perl_dowantarray(pTHX)
1234 I32 gimme = block_gimme();
1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1239 Perl_block_gimme(pTHX)
1243 cxix = dopoptosub(cxstack_ix);
1247 switch (cxstack[cxix].blk_gimme) {
1255 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1262 Perl_is_lvalue_sub(pTHX)
1266 cxix = dopoptosub(cxstack_ix);
1267 assert(cxix >= 0); /* We should only be called from inside subs */
1269 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1270 return cxstack[cxix].blk_sub.lval;
1276 S_dopoptosub(pTHX_ I32 startingblock)
1278 return dopoptosub_at(cxstack, startingblock);
1282 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1285 register PERL_CONTEXT *cx;
1286 for (i = startingblock; i >= 0; i--) {
1288 switch (CxTYPE(cx)) {
1294 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1302 S_dopoptoeval(pTHX_ I32 startingblock)
1305 register PERL_CONTEXT *cx;
1306 for (i = startingblock; i >= 0; i--) {
1308 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1323 register PERL_CONTEXT *cx;
1324 for (i = startingblock; i >= 0; i--) {
1326 switch (CxTYPE(cx)) {
1328 if (ckWARN(WARN_EXITING))
1329 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1333 if (ckWARN(WARN_EXITING))
1334 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1338 if (ckWARN(WARN_EXITING))
1339 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1343 if (ckWARN(WARN_EXITING))
1344 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1348 if (ckWARN(WARN_EXITING))
1349 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1353 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1361 Perl_dounwind(pTHX_ I32 cxix)
1363 register PERL_CONTEXT *cx;
1366 while (cxstack_ix > cxix) {
1368 cx = &cxstack[cxstack_ix];
1369 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1370 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1371 /* Note: we don't need to restore the base context info till the end. */
1372 switch (CxTYPE(cx)) {
1375 continue; /* not break */
1397 Perl_qerror(pTHX_ SV *err)
1400 sv_catsv(ERRSV, err);
1402 sv_catsv(PL_errors, err);
1404 Perl_warn(aTHX_ "%"SVf, err);
1409 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1414 register PERL_CONTEXT *cx;
1419 if (PL_in_eval & EVAL_KEEPERR) {
1420 static char prefix[] = "\t(in cleanup) ";
1425 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1428 if (*e != *message || strNE(e,message))
1432 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1433 sv_catpvn(err, prefix, sizeof(prefix)-1);
1434 sv_catpvn(err, message, msglen);
1435 if (ckWARN(WARN_MISC)) {
1436 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1437 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1442 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 PERL_WRITE_MSG_TO_CONSOLE(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) {
1566 if (PL_DBsub && cxix >= 0 &&
1567 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1571 cxix = dopoptosub_at(ccstack, cxix - 1);
1574 cx = &ccstack[cxix];
1575 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1576 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1577 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1578 field below is defined for any cx. */
1579 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1580 cx = &ccstack[dbcxix];
1583 stashname = CopSTASHPV(cx->blk_oldcop);
1584 if (GIMME != G_ARRAY) {
1587 PUSHs(&PL_sv_undef);
1590 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 & DEBUG_DB_RECURSE_FLAG))
1726 /* don't do recursive DB::DB call */
1738 push_return(PL_op->op_next);
1739 PUSHBLOCK(cx, CXt_SUB, SP);
1742 (void)SvREFCNT_inc(cv);
1743 SAVEVPTR(PL_curpad);
1744 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1745 RETURNOP(CvSTART(cv));
1759 register PERL_CONTEXT *cx;
1760 I32 gimme = GIMME_V;
1762 U32 cxtype = CXt_LOOP;
1770 #ifdef USE_5005THREADS
1771 if (PL_op->op_flags & OPf_SPECIAL) {
1772 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1773 SAVEGENERICSV(*svp);
1777 #endif /* USE_5005THREADS */
1778 if (PL_op->op_targ) {
1779 #ifndef USE_ITHREADS
1780 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1783 SAVEPADSV(PL_op->op_targ);
1784 iterdata = INT2PTR(void*, PL_op->op_targ);
1785 cxtype |= CXp_PADVAR;
1790 svp = &GvSV(gv); /* symbol table variable */
1791 SAVEGENERICSV(*svp);
1794 iterdata = (void*)gv;
1800 PUSHBLOCK(cx, cxtype, SP);
1802 PUSHLOOP(cx, iterdata, MARK);
1804 PUSHLOOP(cx, svp, MARK);
1806 if (PL_op->op_flags & OPf_STACKED) {
1807 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1808 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1810 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1811 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1812 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1813 looks_like_number((SV*)cx->blk_loop.iterary) &&
1814 *SvPVX(cx->blk_loop.iterary) != '0'))
1816 if (SvNV(sv) < IV_MIN ||
1817 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1818 DIE(aTHX_ "Range iterator outside integer range");
1819 cx->blk_loop.iterix = SvIV(sv);
1820 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1823 cx->blk_loop.iterlval = newSVsv(sv);
1827 cx->blk_loop.iterary = PL_curstack;
1828 AvFILLp(PL_curstack) = SP - PL_stack_base;
1829 cx->blk_loop.iterix = MARK - PL_stack_base;
1838 register PERL_CONTEXT *cx;
1839 I32 gimme = GIMME_V;
1845 PUSHBLOCK(cx, CXt_LOOP, SP);
1846 PUSHLOOP(cx, 0, SP);
1854 register PERL_CONTEXT *cx;
1862 newsp = PL_stack_base + cx->blk_loop.resetsp;
1865 if (gimme == G_VOID)
1867 else if (gimme == G_SCALAR) {
1869 *++newsp = sv_mortalcopy(*SP);
1871 *++newsp = &PL_sv_undef;
1875 *++newsp = sv_mortalcopy(*++mark);
1876 TAINT_NOT; /* Each item is independent */
1882 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1883 PL_curpm = newpm; /* ... and pop $1 et al */
1895 register PERL_CONTEXT *cx;
1896 bool popsub2 = FALSE;
1897 bool clear_errsv = FALSE;
1904 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1905 if (cxstack_ix == PL_sortcxix
1906 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1908 if (cxstack_ix > PL_sortcxix)
1909 dounwind(PL_sortcxix);
1910 AvARRAY(PL_curstack)[1] = *SP;
1911 PL_stack_sp = PL_stack_base + 1;
1916 cxix = dopoptosub(cxstack_ix);
1918 DIE(aTHX_ "Can't return outside a subroutine");
1919 if (cxix < cxstack_ix)
1923 switch (CxTYPE(cx)) {
1928 if (!(PL_in_eval & EVAL_KEEPERR))
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) {
2159 /* First try all the kids at this level, since that's likeliest. */
2160 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2161 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2162 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2165 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2166 if (kid == PL_lastgotoprobe)
2168 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2170 (ops[-1]->op_type != OP_NEXTSTATE &&
2171 ops[-1]->op_type != OP_DBSTATE)))
2173 if ((o = dofindlabel(kid, label, ops, oplimit)))
2192 register PERL_CONTEXT *cx;
2193 #define GOTO_DEPTH 64
2194 OP *enterops[GOTO_DEPTH];
2196 int do_dump = (PL_op->op_type == OP_DUMP);
2197 static char must_have_label[] = "goto must have label";
2200 if (PL_op->op_flags & OPf_STACKED) {
2204 /* This egregious kludge implements goto &subroutine */
2205 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2207 register PERL_CONTEXT *cx;
2208 CV* cv = (CV*)SvRV(sv);
2214 if (!CvROOT(cv) && !CvXSUB(cv)) {
2219 /* autoloaded stub? */
2220 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2222 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2223 GvNAMELEN(gv), FALSE);
2224 if (autogv && (cv = GvCV(autogv)))
2226 tmpstr = sv_newmortal();
2227 gv_efullname3(tmpstr, gv, Nullch);
2228 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2230 DIE(aTHX_ "Goto undefined subroutine");
2233 /* First do some returnish stuff. */
2234 cxix = dopoptosub(cxstack_ix);
2236 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2237 if (cxix < cxstack_ix)
2241 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2243 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2244 /* put @_ back onto stack */
2245 AV* av = cx->blk_sub.argarray;
2247 items = AvFILLp(av) + 1;
2249 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2250 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2251 PL_stack_sp += items;
2252 #ifndef USE_5005THREADS
2253 SvREFCNT_dec(GvAV(PL_defgv));
2254 GvAV(PL_defgv) = cx->blk_sub.savearray;
2255 #endif /* USE_5005THREADS */
2256 /* abandon @_ if it got reified */
2258 (void)sv_2mortal((SV*)av); /* delay until return */
2260 av_extend(av, items-1);
2261 AvFLAGS(av) = AVf_REIFY;
2262 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2265 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2267 #ifdef USE_5005THREADS
2268 av = (AV*)PL_curpad[0];
2270 av = GvAV(PL_defgv);
2272 items = AvFILLp(av) + 1;
2274 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2275 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2276 PL_stack_sp += items;
2278 if (CxTYPE(cx) == CXt_SUB &&
2279 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2280 SvREFCNT_dec(cx->blk_sub.cv);
2281 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2282 LEAVE_SCOPE(oldsave);
2284 /* Now do some callish stuff. */
2287 #ifdef PERL_XSUB_OLDSTYLE
2288 if (CvOLDSTYLE(cv)) {
2289 I32 (*fp3)(int,int,int);
2294 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2295 items = (*fp3)(CvXSUBANY(cv).any_i32,
2296 mark - PL_stack_base + 1,
2298 SP = PL_stack_base + items;
2301 #endif /* PERL_XSUB_OLDSTYLE */
2306 PL_stack_sp--; /* There is no cv arg. */
2307 /* Push a mark for the start of arglist */
2309 (void)(*CvXSUB(cv))(aTHX_ cv);
2310 /* Pop the current context like a decent sub should */
2311 POPBLOCK(cx, PL_curpm);
2312 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2315 return pop_return();
2318 AV* padlist = CvPADLIST(cv);
2319 SV** svp = AvARRAY(padlist);
2320 if (CxTYPE(cx) == CXt_EVAL) {
2321 PL_in_eval = cx->blk_eval.old_in_eval;
2322 PL_eval_root = cx->blk_eval.old_eval_root;
2323 cx->cx_type = CXt_SUB;
2324 cx->blk_sub.hasargs = 0;
2326 cx->blk_sub.cv = cv;
2327 cx->blk_sub.olddepth = CvDEPTH(cv);
2329 if (CvDEPTH(cv) < 2)
2330 (void)SvREFCNT_inc(cv);
2331 else { /* save temporaries on recursion? */
2332 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2333 sub_crush_depth(cv);
2334 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2335 AV *newpad = newAV();
2336 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2337 I32 ix = AvFILLp((AV*)svp[1]);
2338 I32 names_fill = AvFILLp((AV*)svp[0]);
2339 svp = AvARRAY(svp[0]);
2340 for ( ;ix > 0; ix--) {
2341 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2342 char *name = SvPVX(svp[ix]);
2343 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2346 /* outer lexical or anon code */
2347 av_store(newpad, ix,
2348 SvREFCNT_inc(oldpad[ix]) );
2350 else { /* our own lexical */
2352 av_store(newpad, ix, sv = (SV*)newAV());
2353 else if (*name == '%')
2354 av_store(newpad, ix, sv = (SV*)newHV());
2356 av_store(newpad, ix, sv = NEWSV(0,0));
2360 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2361 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2364 av_store(newpad, ix, sv = NEWSV(0,0));
2368 if (cx->blk_sub.hasargs) {
2371 av_store(newpad, 0, (SV*)av);
2372 AvFLAGS(av) = AVf_REIFY;
2374 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2375 AvFILLp(padlist) = CvDEPTH(cv);
2376 svp = AvARRAY(padlist);
2379 #ifdef USE_5005THREADS
2380 if (!cx->blk_sub.hasargs) {
2381 AV* av = (AV*)PL_curpad[0];
2383 items = AvFILLp(av) + 1;
2385 /* Mark is at the end of the stack. */
2387 Copy(AvARRAY(av), SP + 1, items, SV*);
2392 #endif /* USE_5005THREADS */
2393 SAVEVPTR(PL_curpad);
2394 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2395 #ifndef USE_5005THREADS
2396 if (cx->blk_sub.hasargs)
2397 #endif /* USE_5005THREADS */
2399 AV* av = (AV*)PL_curpad[0];
2402 #ifndef USE_5005THREADS
2403 cx->blk_sub.savearray = GvAV(PL_defgv);
2404 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2405 #endif /* USE_5005THREADS */
2406 cx->blk_sub.oldcurpad = PL_curpad;
2407 cx->blk_sub.argarray = av;
2410 if (items >= AvMAX(av) + 1) {
2412 if (AvARRAY(av) != ary) {
2413 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2414 SvPVX(av) = (char*)ary;
2416 if (items >= AvMAX(av) + 1) {
2417 AvMAX(av) = items - 1;
2418 Renew(ary,items+1,SV*);
2420 SvPVX(av) = (char*)ary;
2423 Copy(mark,AvARRAY(av),items,SV*);
2424 AvFILLp(av) = items - 1;
2425 assert(!AvREAL(av));
2432 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2434 * We do not care about using sv to call CV;
2435 * it's for informational purposes only.
2437 SV *sv = GvSV(PL_DBsub);
2440 if (PERLDB_SUB_NN) {
2441 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2444 gv_efullname3(sv, CvGV(cv), Nullch);
2447 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2448 PUSHMARK( PL_stack_sp );
2449 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2453 RETURNOP(CvSTART(cv));
2457 label = SvPV(sv,n_a);
2458 if (!(do_dump || *label))
2459 DIE(aTHX_ must_have_label);
2462 else if (PL_op->op_flags & OPf_SPECIAL) {
2464 DIE(aTHX_ must_have_label);
2467 label = cPVOP->op_pv;
2469 if (label && *label) {
2471 bool leaving_eval = FALSE;
2472 PERL_CONTEXT *last_eval_cx = 0;
2476 PL_lastgotoprobe = 0;
2478 for (ix = cxstack_ix; ix >= 0; ix--) {
2480 switch (CxTYPE(cx)) {
2482 leaving_eval = TRUE;
2483 if (CxREALEVAL(cx)) {
2484 gotoprobe = (last_eval_cx ?
2485 last_eval_cx->blk_eval.old_eval_root :
2490 /* else fall through */
2492 gotoprobe = cx->blk_oldcop->op_sibling;
2498 gotoprobe = cx->blk_oldcop->op_sibling;
2500 gotoprobe = PL_main_root;
2503 if (CvDEPTH(cx->blk_sub.cv)) {
2504 gotoprobe = CvROOT(cx->blk_sub.cv);
2510 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2513 DIE(aTHX_ "panic: goto");
2514 gotoprobe = PL_main_root;
2518 retop = dofindlabel(gotoprobe, label,
2519 enterops, enterops + GOTO_DEPTH);
2523 PL_lastgotoprobe = gotoprobe;
2526 DIE(aTHX_ "Can't find label %s", label);
2528 /* if we're leaving an eval, check before we pop any frames
2529 that we're not going to punt, otherwise the error
2532 if (leaving_eval && *enterops && enterops[1]) {
2534 for (i = 1; enterops[i]; i++)
2535 if (enterops[i]->op_type == OP_ENTERITER)
2536 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2539 /* pop unwanted frames */
2541 if (ix < cxstack_ix) {
2548 oldsave = PL_scopestack[PL_scopestack_ix];
2549 LEAVE_SCOPE(oldsave);
2552 /* push wanted frames */
2554 if (*enterops && enterops[1]) {
2556 for (ix = 1; enterops[ix]; ix++) {
2557 PL_op = enterops[ix];
2558 /* Eventually we may want to stack the needed arguments
2559 * for each op. For now, we punt on the hard ones. */
2560 if (PL_op->op_type == OP_ENTERITER)
2561 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2562 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2570 if (!retop) retop = PL_main_start;
2572 PL_restartop = retop;
2573 PL_do_undump = TRUE;
2577 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2578 PL_do_undump = FALSE;
2594 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2596 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2599 PL_exit_flags |= PERL_EXIT_EXPECTED;
2601 PUSHs(&PL_sv_undef);
2609 NV value = SvNVx(GvSV(cCOP->cop_gv));
2610 register I32 match = I_32(value);
2613 if (((NV)match) > value)
2614 --match; /* was fractional--truncate other way */
2616 match -= cCOP->uop.scop.scop_offset;
2619 else if (match > cCOP->uop.scop.scop_max)
2620 match = cCOP->uop.scop.scop_max;
2621 PL_op = cCOP->uop.scop.scop_next[match];
2631 PL_op = PL_op->op_next; /* can't assume anything */
2634 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2635 match -= cCOP->uop.scop.scop_offset;
2638 else if (match > cCOP->uop.scop.scop_max)
2639 match = cCOP->uop.scop.scop_max;
2640 PL_op = cCOP->uop.scop.scop_next[match];
2649 S_save_lines(pTHX_ AV *array, SV *sv)
2651 register char *s = SvPVX(sv);
2652 register char *send = SvPVX(sv) + SvCUR(sv);
2654 register I32 line = 1;
2656 while (s && s < send) {
2657 SV *tmpstr = NEWSV(85,0);
2659 sv_upgrade(tmpstr, SVt_PVMG);
2660 t = strchr(s, '\n');
2666 sv_setpvn(tmpstr, s, t - s);
2667 av_store(array, line++, tmpstr);
2672 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2674 S_docatch_body(pTHX_ va_list args)
2676 return docatch_body();
2681 S_docatch_body(pTHX)
2688 S_docatch(pTHX_ OP *o)
2692 volatile PERL_SI *cursi = PL_curstackinfo;
2696 assert(CATCH_GET == TRUE);
2699 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2701 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2707 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2713 if (PL_restartop && cursi == PL_curstackinfo) {
2714 PL_op = PL_restartop;
2731 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2732 /* sv Text to convert to OP tree. */
2733 /* startop op_free() this to undo. */
2734 /* code Short string id of the caller. */
2736 dSP; /* Make POPBLOCK work. */
2739 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2743 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2744 char *tmpbuf = tbuf;
2750 /* switch to eval mode */
2752 if (PL_curcop == &PL_compiling) {
2753 SAVECOPSTASH_FREE(&PL_compiling);
2754 CopSTASH_set(&PL_compiling, PL_curstash);
2756 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2757 SV *sv = sv_newmortal();
2758 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2759 code, (unsigned long)++PL_evalseq,
2760 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2764 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2765 SAVECOPFILE_FREE(&PL_compiling);
2766 CopFILE_set(&PL_compiling, tmpbuf+2);
2767 SAVECOPLINE(&PL_compiling);
2768 CopLINE_set(&PL_compiling, 1);
2769 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2770 deleting the eval's FILEGV from the stash before gv_check() runs
2771 (i.e. before run-time proper). To work around the coredump that
2772 ensues, we always turn GvMULTI_on for any globals that were
2773 introduced within evals. See force_ident(). GSAR 96-10-12 */
2774 safestr = savepv(tmpbuf);
2775 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2777 #ifdef OP_IN_REGISTER
2782 PL_hints &= HINT_UTF8;
2785 PL_op->op_type = OP_ENTEREVAL;
2786 PL_op->op_flags = 0; /* Avoid uninit warning. */
2787 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2788 PUSHEVAL(cx, 0, Nullgv);
2789 rop = doeval(G_SCALAR, startop);
2790 POPBLOCK(cx,PL_curpm);
2793 (*startop)->op_type = OP_NULL;
2794 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2796 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2798 if (PL_curcop == &PL_compiling)
2799 PL_compiling.op_private = PL_hints;
2800 #ifdef OP_IN_REGISTER
2806 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2808 S_doeval(pTHX_ int gimme, OP** startop)
2816 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2817 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2822 /* set up a scratch pad */
2825 SAVEVPTR(PL_curpad);
2826 SAVESPTR(PL_comppad);
2827 SAVESPTR(PL_comppad_name);
2828 SAVEI32(PL_comppad_name_fill);
2829 SAVEI32(PL_min_intro_pending);
2830 SAVEI32(PL_max_intro_pending);
2833 for (i = cxstack_ix - 1; i >= 0; i--) {
2834 PERL_CONTEXT *cx = &cxstack[i];
2835 if (CxTYPE(cx) == CXt_EVAL)
2837 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2838 caller = cx->blk_sub.cv;
2843 SAVESPTR(PL_compcv);
2844 PL_compcv = (CV*)NEWSV(1104,0);
2845 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2846 CvEVAL_on(PL_compcv);
2847 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2848 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2850 #ifdef USE_5005THREADS
2851 CvOWNER(PL_compcv) = 0;
2852 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2853 MUTEX_INIT(CvMUTEXP(PL_compcv));
2854 #endif /* USE_5005THREADS */
2856 PL_comppad = newAV();
2857 av_push(PL_comppad, Nullsv);
2858 PL_curpad = AvARRAY(PL_comppad);
2859 PL_comppad_name = newAV();
2860 PL_comppad_name_fill = 0;
2861 PL_min_intro_pending = 0;
2863 #ifdef USE_5005THREADS
2864 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2865 PL_curpad[0] = (SV*)newAV();
2866 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2867 #endif /* USE_5005THREADS */
2869 comppadlist = newAV();
2870 AvREAL_off(comppadlist);
2871 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2872 av_store(comppadlist, 1, (SV*)PL_comppad);
2873 CvPADLIST(PL_compcv) = comppadlist;
2876 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2878 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2881 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2883 /* make sure we compile in the right package */
2885 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2886 SAVESPTR(PL_curstash);
2887 PL_curstash = CopSTASH(PL_curcop);
2889 SAVESPTR(PL_beginav);
2890 PL_beginav = newAV();
2891 SAVEFREESV(PL_beginav);
2892 SAVEI32(PL_error_count);
2894 /* try to compile it */
2896 PL_eval_root = Nullop;
2898 PL_curcop = &PL_compiling;
2899 PL_curcop->cop_arybase = 0;
2900 if (saveop && saveop->op_flags & OPf_SPECIAL)
2901 PL_in_eval |= EVAL_KEEPERR;
2904 if (yyparse() || PL_error_count || !PL_eval_root) {
2908 I32 optype = 0; /* Might be reset by POPEVAL. */
2913 op_free(PL_eval_root);
2914 PL_eval_root = Nullop;
2916 SP = PL_stack_base + POPMARK; /* pop original mark */
2918 POPBLOCK(cx,PL_curpm);
2924 if (optype == OP_REQUIRE) {
2925 char* msg = SvPVx(ERRSV, n_a);
2926 DIE(aTHX_ "%sCompilation failed in require",
2927 *msg ? msg : "Unknown error\n");
2930 char* msg = SvPVx(ERRSV, n_a);
2932 POPBLOCK(cx,PL_curpm);
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
2937 #ifdef USE_5005THREADS
2938 MUTEX_LOCK(&PL_eval_mutex);
2940 COND_SIGNAL(&PL_eval_cond);
2941 MUTEX_UNLOCK(&PL_eval_mutex);
2942 #endif /* USE_5005THREADS */
2945 CopLINE_set(&PL_compiling, 0);
2947 *startop = PL_eval_root;
2948 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2949 CvOUTSIDE(PL_compcv) = Nullcv;
2951 SAVEFREEOP(PL_eval_root);
2953 scalarvoid(PL_eval_root);
2954 else if (gimme & G_ARRAY)
2957 scalar(PL_eval_root);
2959 DEBUG_x(dump_eval());
2961 /* Register with debugger: */
2962 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2963 CV *cv = get_cv("DB::postponed", FALSE);
2967 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2969 call_sv((SV*)cv, G_DISCARD);
2973 /* compiled okay, so do it */
2975 CvDEPTH(PL_compcv) = 1;
2976 SP = PL_stack_base + POPMARK; /* pop original mark */
2977 PL_op = saveop; /* The caller may need it. */
2978 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2979 #ifdef USE_5005THREADS
2980 MUTEX_LOCK(&PL_eval_mutex);
2982 COND_SIGNAL(&PL_eval_cond);
2983 MUTEX_UNLOCK(&PL_eval_mutex);
2984 #endif /* USE_5005THREADS */
2986 RETURNOP(PL_eval_start);
2990 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2992 STRLEN namelen = strlen(name);
2995 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2996 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2997 char *pmc = SvPV_nolen(pmcsv);
3000 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3001 fp = PerlIO_open(name, mode);
3004 if (PerlLIO_stat(name, &pmstat) < 0 ||
3005 pmstat.st_mtime < pmcstat.st_mtime)
3007 fp = PerlIO_open(pmc, mode);
3010 fp = PerlIO_open(name, mode);
3013 SvREFCNT_dec(pmcsv);
3016 fp = PerlIO_open(name, mode);
3024 register PERL_CONTEXT *cx;
3028 char *tryname = Nullch;
3029 SV *namesv = Nullsv;
3031 I32 gimme = GIMME_V;
3032 PerlIO *tryrsfp = 0;
3034 int filter_has_file = 0;
3035 GV *filter_child_proc = 0;
3036 SV *filter_state = 0;
3044 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3045 UV rev = 0, ver = 0, sver = 0;
3047 U8 *s = (U8*)SvPVX(sv);
3048 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3050 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3053 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3056 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3059 if (PERL_REVISION < rev
3060 || (PERL_REVISION == rev
3061 && (PERL_VERSION < ver
3062 || (PERL_VERSION == ver
3063 && PERL_SUBVERSION < sver))))
3065 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3066 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3067 PERL_VERSION, PERL_SUBVERSION);
3069 if (ckWARN(WARN_PORTABLE))
3070 Perl_warner(aTHX_ WARN_PORTABLE,
3071 "v-string in use/require non-portable");
3074 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3075 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3076 + ((NV)PERL_SUBVERSION/(NV)1000000)
3077 + 0.00000099 < SvNV(sv))
3081 NV nver = (nrev - rev) * 1000;
3082 UV ver = (UV)(nver + 0.0009);
3083 NV nsver = (nver - ver) * 1000;
3084 UV sver = (UV)(nsver + 0.0009);
3086 /* help out with the "use 5.6" confusion */
3087 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3088 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3089 "this is only v%d.%d.%d, stopped"
3090 " (did you mean v%"UVuf".%03"UVuf"?)",
3091 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3092 PERL_SUBVERSION, rev, ver/100);
3095 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3096 "this is only v%d.%d.%d, stopped",
3097 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3104 name = SvPV(sv, len);
3105 if (!(name && len > 0 && *name))
3106 DIE(aTHX_ "Null filename used");
3107 TAINT_PROPER("require");
3108 if (PL_op->op_type == OP_REQUIRE &&
3109 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3110 *svp != &PL_sv_undef)
3113 /* prepare to compile file */
3115 #ifdef MACOS_TRADITIONAL
3116 if (PERL_FILE_IS_ABSOLUTE(name)
3117 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3120 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3121 /* We consider paths of the form :a:b ambiguous and interpret them first
3122 as global then as local
3124 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3130 if (PERL_FILE_IS_ABSOLUTE(name)
3131 || (*name == '.' && (name[1] == '/' ||
3132 (name[1] == '.' && name[2] == '/'))))
3135 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3139 AV *ar = GvAVn(PL_incgv);
3143 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3146 namesv = NEWSV(806, 0);
3147 for (i = 0; i <= AvFILL(ar); i++) {
3148 SV *dirsv = *av_fetch(ar, i, TRUE);
3154 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3155 && !sv_isobject(loader))
3157 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3160 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3161 PTR2UV(SvRV(dirsv)), name);
3162 tryname = SvPVX(namesv);
3173 if (sv_isobject(loader))
3174 count = call_method("INC", G_ARRAY);
3176 count = call_sv(loader, G_ARRAY);
3186 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3190 if (SvTYPE(arg) == SVt_PVGV) {
3191 IO *io = GvIO((GV *)arg);
3196 tryrsfp = IoIFP(io);
3197 if (IoTYPE(io) == IoTYPE_PIPE) {
3198 /* reading from a child process doesn't
3199 nest -- when returning from reading
3200 the inner module, the outer one is
3201 unreadable (closed?) I've tried to
3202 save the gv to manage the lifespan of
3203 the pipe, but this didn't help. XXX */
3204 filter_child_proc = (GV *)arg;
3205 (void)SvREFCNT_inc(filter_child_proc);
3208 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3209 PerlIO_close(IoOFP(io));
3221 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3223 (void)SvREFCNT_inc(filter_sub);
3226 filter_state = SP[i];
3227 (void)SvREFCNT_inc(filter_state);
3231 tryrsfp = PerlIO_open("/dev/null",
3246 filter_has_file = 0;
3247 if (filter_child_proc) {
3248 SvREFCNT_dec(filter_child_proc);
3249 filter_child_proc = 0;
3252 SvREFCNT_dec(filter_state);
3256 SvREFCNT_dec(filter_sub);
3261 char *dir = SvPVx(dirsv, n_a);
3262 #ifdef MACOS_TRADITIONAL
3264 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3268 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3270 sv_setpv(namesv, unixdir);
3271 sv_catpv(namesv, unixname);
3273 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3276 TAINT_PROPER("require");
3277 tryname = SvPVX(namesv);
3278 #ifdef MACOS_TRADITIONAL
3280 /* Convert slashes in the name part, but not the directory part, to colons */
3282 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3286 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3288 if (tryname[0] == '.' && tryname[1] == '/')
3296 SAVECOPFILE_FREE(&PL_compiling);
3297 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3298 SvREFCNT_dec(namesv);
3300 if (PL_op->op_type == OP_REQUIRE) {
3301 char *msgstr = name;
3302 if (namesv) { /* did we lookup @INC? */
3303 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3304 SV *dirmsgsv = NEWSV(0, 0);
3305 AV *ar = GvAVn(PL_incgv);
3307 sv_catpvn(msg, " in @INC", 8);
3308 if (instr(SvPVX(msg), ".h "))
3309 sv_catpv(msg, " (change .h to .ph maybe?)");
3310 if (instr(SvPVX(msg), ".ph "))
3311 sv_catpv(msg, " (did you run h2ph?)");
3312 sv_catpv(msg, " (@INC contains:");
3313 for (i = 0; i <= AvFILL(ar); i++) {
3314 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3315 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3316 sv_catsv(msg, dirmsgsv);
3318 sv_catpvn(msg, ")", 1);
3319 SvREFCNT_dec(dirmsgsv);
3320 msgstr = SvPV_nolen(msg);
3322 DIE(aTHX_ "Can't locate %s", msgstr);
3328 SETERRNO(0, SS$_NORMAL);
3330 /* Assume success here to prevent recursive requirement. */
3332 /* Check whether a hook in @INC has already filled %INC */
3333 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3334 (void)hv_store(GvHVn(PL_incgv), name, len,
3335 (hook_sv ? SvREFCNT_inc(hook_sv)
3336 : newSVpv(CopFILE(&PL_compiling), 0)),
3342 lex_start(sv_2mortal(newSVpvn("",0)));
3343 SAVEGENERICSV(PL_rsfp_filters);
3344 PL_rsfp_filters = Nullav;
3349 SAVESPTR(PL_compiling.cop_warnings);
3350 if (PL_dowarn & G_WARN_ALL_ON)
3351 PL_compiling.cop_warnings = pWARN_ALL ;
3352 else if (PL_dowarn & G_WARN_ALL_OFF)
3353 PL_compiling.cop_warnings = pWARN_NONE ;
3355 PL_compiling.cop_warnings = pWARN_STD ;
3356 SAVESPTR(PL_compiling.cop_io);
3357 PL_compiling.cop_io = Nullsv;
3359 if (filter_sub || filter_child_proc) {
3360 SV *datasv = filter_add(run_user_filter, Nullsv);
3361 IoLINES(datasv) = filter_has_file;
3362 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3363 IoTOP_GV(datasv) = (GV *)filter_state;
3364 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3367 /* switch to eval mode */
3368 push_return(PL_op->op_next);
3369 PUSHBLOCK(cx, CXt_EVAL, SP);
3370 PUSHEVAL(cx, name, Nullgv);
3372 SAVECOPLINE(&PL_compiling);
3373 CopLINE_set(&PL_compiling, 0);
3376 #ifdef USE_5005THREADS
3377 MUTEX_LOCK(&PL_eval_mutex);
3378 if (PL_eval_owner && PL_eval_owner != thr)
3379 while (PL_eval_owner)
3380 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3381 PL_eval_owner = thr;
3382 MUTEX_UNLOCK(&PL_eval_mutex);
3383 #endif /* USE_5005THREADS */
3385 /* Store and reset encoding. */
3386 encoding = PL_encoding;
3387 PL_encoding = Nullsv;
3389 op = DOCATCH(doeval(gimme, NULL));
3391 /* Restore encoding. */
3392 PL_encoding = encoding;
3399 return pp_require();
3405 register PERL_CONTEXT *cx;
3407 I32 gimme = GIMME_V, was = PL_sub_generation;
3408 char tbuf[TYPE_DIGITS(long) + 12];
3409 char *tmpbuf = tbuf;
3414 if (!SvPV(sv,len) || !len)
3416 TAINT_PROPER("eval");
3422 /* switch to eval mode */
3424 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3425 SV *sv = sv_newmortal();
3426 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3427 (unsigned long)++PL_evalseq,
3428 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3432 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3433 SAVECOPFILE_FREE(&PL_compiling);
3434 CopFILE_set(&PL_compiling, tmpbuf+2);
3435 SAVECOPLINE(&PL_compiling);
3436 CopLINE_set(&PL_compiling, 1);
3437 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3438 deleting the eval's FILEGV from the stash before gv_check() runs
3439 (i.e. before run-time proper). To work around the coredump that
3440 ensues, we always turn GvMULTI_on for any globals that were
3441 introduced within evals. See force_ident(). GSAR 96-10-12 */
3442 safestr = savepv(tmpbuf);
3443 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3445 PL_hints = PL_op->op_targ;
3446 SAVESPTR(PL_compiling.cop_warnings);
3447 if (specialWARN(PL_curcop->cop_warnings))
3448 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3450 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3451 SAVEFREESV(PL_compiling.cop_warnings);
3453 SAVESPTR(PL_compiling.cop_io);
3454 if (specialCopIO(PL_curcop->cop_io))
3455 PL_compiling.cop_io = PL_curcop->cop_io;
3457 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3458 SAVEFREESV(PL_compiling.cop_io);
3461 push_return(PL_op->op_next);
3462 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3463 PUSHEVAL(cx, 0, Nullgv);
3465 /* prepare to compile string */
3467 if (PERLDB_LINE && PL_curstash != PL_debstash)
3468 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3470 #ifdef USE_5005THREADS
3471 MUTEX_LOCK(&PL_eval_mutex);
3472 if (PL_eval_owner && PL_eval_owner != thr)
3473 while (PL_eval_owner)
3474 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3475 PL_eval_owner = thr;
3476 MUTEX_UNLOCK(&PL_eval_mutex);
3477 #endif /* USE_5005THREADS */
3478 ret = doeval(gimme, NULL);
3479 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3480 && ret != PL_op->op_next) { /* Successive compilation. */
3481 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3483 return DOCATCH(ret);
3493 register PERL_CONTEXT *cx;
3495 U8 save_flags = PL_op -> op_flags;
3500 retop = pop_return();
3503 if (gimme == G_VOID)
3505 else if (gimme == G_SCALAR) {
3508 if (SvFLAGS(TOPs) & SVs_TEMP)
3511 *MARK = sv_mortalcopy(TOPs);
3515 *MARK = &PL_sv_undef;
3520 /* in case LEAVE wipes old return values */
3521 for (mark = newsp + 1; mark <= SP; mark++) {
3522 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3523 *mark = sv_mortalcopy(*mark);
3524 TAINT_NOT; /* Each item is independent */
3528 PL_curpm = newpm; /* Don't pop $1 et al till now */
3531 assert(CvDEPTH(PL_compcv) == 1);
3533 CvDEPTH(PL_compcv) = 0;
3536 if (optype == OP_REQUIRE &&
3537 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3539 /* Unassume the success we assumed earlier. */
3540 SV *nsv = cx->blk_eval.old_namesv;
3541 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3542 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3543 /* die_where() did LEAVE, or we won't be here */
3547 if (!(save_flags & OPf_SPECIAL))
3557 register PERL_CONTEXT *cx;
3558 I32 gimme = GIMME_V;
3563 push_return(cLOGOP->op_other->op_next);
3564 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3567 PL_in_eval = EVAL_INEVAL;
3570 return DOCATCH(PL_op->op_next);
3580 register PERL_CONTEXT *cx;
3588 if (gimme == G_VOID)
3590 else if (gimme == G_SCALAR) {
3593 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3596 *MARK = sv_mortalcopy(TOPs);
3600 *MARK = &PL_sv_undef;
3605 /* in case LEAVE wipes old return values */
3606 for (mark = newsp + 1; mark <= SP; mark++) {
3607 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3608 *mark = sv_mortalcopy(*mark);
3609 TAINT_NOT; /* Each item is independent */
3613 PL_curpm = newpm; /* Don't pop $1 et al till now */
3621 S_doparseform(pTHX_ SV *sv)
3624 register char *s = SvPV_force(sv, len);
3625 register char *send = s + len;
3626 register char *base = Nullch;
3627 register I32 skipspaces = 0;
3628 bool noblank = FALSE;
3629 bool repeat = FALSE;
3630 bool postspace = FALSE;
3638 Perl_croak(aTHX_ "Null picture in formline");
3640 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3645 *fpc++ = FF_LINEMARK;
3646 noblank = repeat = FALSE;
3664 case ' ': case '\t':
3675 *fpc++ = FF_LITERAL;
3683 *fpc++ = skipspaces;
3687 *fpc++ = FF_NEWLINE;
3691 arg = fpc - linepc + 1;
3698 *fpc++ = FF_LINEMARK;
3699 noblank = repeat = FALSE;
3708 ischop = s[-1] == '^';
3714 arg = (s - base) - 1;
3716 *fpc++ = FF_LITERAL;
3725 *fpc++ = FF_LINEGLOB;
3727 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3728 arg = ischop ? 512 : 0;
3738 arg |= 256 + (s - f);
3740 *fpc++ = s - base; /* fieldsize for FETCH */
3741 *fpc++ = FF_DECIMAL;
3744 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3745 arg = ischop ? 512 : 0;
3747 s++; /* skip the '0' first */
3756 arg |= 256 + (s - f);
3758 *fpc++ = s - base; /* fieldsize for FETCH */
3759 *fpc++ = FF_0DECIMAL;
3764 bool ismore = FALSE;
3767 while (*++s == '>') ;
3768 prespace = FF_SPACE;
3770 else if (*s == '|') {
3771 while (*++s == '|') ;
3772 prespace = FF_HALFSPACE;
3777 while (*++s == '<') ;
3780 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3784 *fpc++ = s - base; /* fieldsize for FETCH */
3786 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3804 { /* need to jump to the next word */
3806 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3807 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3808 s = SvPVX(sv) + SvCUR(sv) + z;
3810 Copy(fops, s, arg, U16);
3812 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3817 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3819 * The original code was written in conjunction with BSD Computer Software
3820 * Research Group at University of California, Berkeley.
3822 * See also: "Optimistic Merge Sort" (SODA '92)
3824 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3826 * The code can be distributed under the same terms as Perl itself.
3831 #include <sys/types.h>
3835 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3836 #define Safefree(VAR) free(VAR)
3837 typedef int (*SVCOMPARE_t) (pTHX_ SV*, SV*);
3838 #endif /* TESTHARNESS */
3840 typedef char * aptr; /* pointer for arithmetic on sizes */
3841 typedef SV * gptr; /* pointers in our lists */
3843 /* Binary merge internal sort, with a few special mods
3844 ** for the special perl environment it now finds itself in.
3846 ** Things that were once options have been hotwired
3847 ** to values suitable for this use. In particular, we'll always
3848 ** initialize looking for natural runs, we'll always produce stable
3849 ** output, and we'll always do Peter McIlroy's binary merge.
3852 /* Pointer types for arithmetic and storage and convenience casts */
3854 #define APTR(P) ((aptr)(P))
3855 #define GPTP(P) ((gptr *)(P))
3856 #define GPPP(P) ((gptr **)(P))
3859 /* byte offset from pointer P to (larger) pointer Q */
3860 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3862 #define PSIZE sizeof(gptr)
3864 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3867 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3868 #define PNBYTE(N) ((N) << (PSHIFT))
3869 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3871 /* Leave optimization to compiler */
3872 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3873 #define PNBYTE(N) ((N) * (PSIZE))
3874 #define PINDEX(P, N) (GPTP(P) + (N))
3877 /* Pointer into other corresponding to pointer into this */
3878 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3880 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3883 /* Runs are identified by a pointer in the auxilliary list.
3884 ** The pointer is at the start of the list,
3885 ** and it points to the start of the next list.
3886 ** NEXT is used as an lvalue, too.
3889 #define NEXT(P) (*GPPP(P))
3892 /* PTHRESH is the minimum number of pairs with the same sense to justify
3893 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3894 ** not just elements, so PTHRESH == 8 means a run of 16.
3899 /* RTHRESH is the number of elements in a run that must compare low
3900 ** to the low element from the opposing run before we justify
3901 ** doing a binary rampup instead of single stepping.
3902 ** In random input, N in a row low should only happen with
3903 ** probability 2^(1-N), so we can risk that we are dealing
3904 ** with orderly input without paying much when we aren't.
3911 ** Overview of algorithm and variables.
3912 ** The array of elements at list1 will be organized into runs of length 2,
3913 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3914 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3916 ** Unless otherwise specified, pair pointers address the first of two elements.
3918 ** b and b+1 are a pair that compare with sense ``sense''.
3919 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3921 ** p2 parallels b in the list2 array, where runs are defined by
3924 ** t represents the ``top'' of the adjacent pairs that might extend
3925 ** the run beginning at b. Usually, t addresses a pair
3926 ** that compares with opposite sense from (b,b+1).
3927 ** However, it may also address a singleton element at the end of list1,
3928 ** or it may be equal to ``last'', the first element beyond list1.
3930 ** r addresses the Nth pair following b. If this would be beyond t,
3931 ** we back it off to t. Only when r is less than t do we consider the
3932 ** run long enough to consider checking.
3934 ** q addresses a pair such that the pairs at b through q already form a run.
3935 ** Often, q will equal b, indicating we only are sure of the pair itself.
3936 ** However, a search on the previous cycle may have revealed a longer run,
3937 ** so q may be greater than b.
3939 ** p is used to work back from a candidate r, trying to reach q,
3940 ** which would mean b through r would be a run. If we discover such a run,
3941 ** we start q at r and try to push it further towards t.
3942 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3943 ** In any event, after the check (if any), we have two main cases.
3945 ** 1) Short run. b <= q < p <= r <= t.
3946 ** b through q is a run (perhaps trivial)
3947 ** q through p are uninteresting pairs
3948 ** p through r is a run
3950 ** 2) Long run. b < r <= q < t.
3951 ** b through q is a run (of length >= 2 * PTHRESH)
3953 ** Note that degenerate cases are not only possible, but likely.
3954 ** For example, if the pair following b compares with opposite sense,
3955 ** then b == q < p == r == t.
3960 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3963 register gptr *b, *p, *q, *t, *p2;
3964 register gptr c, *last, *r;
3968 last = PINDEX(b, nmemb);
3969 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3970 for (p2 = list2; b < last; ) {
3971 /* We just started, or just reversed sense.
3972 ** Set t at end of pairs with the prevailing sense.
3974 for (p = b+2, t = p; ++p < last; t = ++p) {
3975 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3978 /* Having laid out the playing field, look for long runs */
3980 p = r = b + (2 * PTHRESH);
3981 if (r >= t) p = r = t; /* too short to care about */
3983 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3986 /* b through r is a (long) run.
3987 ** Extend it as far as possible.
3990 while (((p += 2) < t) &&
3991 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3992 r = p = q + 2; /* no simple pairs, no after-run */
3995 if (q > b) { /* run of greater than 2 at b */
3998 /* pick up singleton, if possible */
4000 ((t + 1) == last) &&
4001 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
4002 savep = r = p = q = last;
4003 p2 = NEXT(p2) = p2 + (p - b);
4004 if (sense) while (b < --p) {
4011 while (q < p) { /* simple pairs */
4012 p2 = NEXT(p2) = p2 + 2;
4019 if (((b = p) == t) && ((t+1) == last)) {
4031 /* Overview of bmerge variables:
4033 ** list1 and list2 address the main and auxiliary arrays.
4034 ** They swap identities after each merge pass.
4035 ** Base points to the original list1, so we can tell if
4036 ** the pointers ended up where they belonged (or must be copied).
4038 ** When we are merging two lists, f1 and f2 are the next elements
4039 ** on the respective lists. l1 and l2 mark the end of the lists.
4040 ** tp2 is the current location in the merged list.
4042 ** p1 records where f1 started.
4043 ** After the merge, a new descriptor is built there.
4045 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4046 ** It is used to identify and delimit the runs.
4048 ** In the heat of determining where q, the greater of the f1/f2 elements,
4049 ** belongs in the other list, b, t and p, represent bottom, top and probe
4050 ** locations, respectively, in the other list.
4051 ** They make convenient temporary pointers in other places.
4057 Sort an array. Here is an example:
4059 sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
4065 Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4069 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4070 gptr *aux, *list2, *p2, *last;
4074 if (nmemb <= 1) return; /* sorted trivially */
4075 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4077 dynprep(aTHX_ list1, list2, nmemb, cmp);
4078 last = PINDEX(list2, nmemb);
4079 while (NEXT(list2) != last) {
4080 /* More than one run remains. Do some merging to reduce runs. */
4082 for (tp2 = p2 = list2; p2 != last;) {
4083 /* The new first run begins where the old second list ended.
4084 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4088 f2 = l1 = POTHER(t, list2, list1);
4089 if (t != last) t = NEXT(t);
4090 l2 = POTHER(t, list2, list1);
4092 while (f1 < l1 && f2 < l2) {
4093 /* If head 1 is larger than head 2, find ALL the elements
4094 ** in list 2 strictly less than head1, write them all,
4095 ** then head 1. Then compare the new heads, and repeat,
4096 ** until one or both lists are exhausted.
4098 ** In all comparisons (after establishing
4099 ** which head to merge) the item to merge
4100 ** (at pointer q) is the first operand of
4101 ** the comparison. When we want to know
4102 ** if ``q is strictly less than the other'',
4104 ** cmp(q, other) < 0
4105 ** because stability demands that we treat equality
4106 ** as high when q comes from l2, and as low when
4107 ** q was from l1. So we ask the question by doing
4108 ** cmp(q, other) <= sense
4109 ** and make sense == 0 when equality should look low,
4110 ** and -1 when equality should look high.
4114 if (cmp(aTHX_ *f1, *f2) <= 0) {
4115 q = f2; b = f1; t = l1;
4118 q = f1; b = f2; t = l2;
4125 ** Leave t at something strictly
4126 ** greater than q (or at the end of the list),
4127 ** and b at something strictly less than q.
4129 for (i = 1, run = 0 ;;) {
4130 if ((p = PINDEX(b, i)) >= t) {
4132 if (((p = PINDEX(t, -1)) > b) &&
4133 (cmp(aTHX_ *q, *p) <= sense))
4137 } else if (cmp(aTHX_ *q, *p) <= sense) {
4141 if (++run >= RTHRESH) i += i;
4145 /* q is known to follow b and must be inserted before t.
4146 ** Increment b, so the range of possibilities is [b,t).
4147 ** Round binary split down, to favor early appearance.
4148 ** Adjust b and t until q belongs just before t.
4153 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4154 if (cmp(aTHX_ *q, *p) <= sense) {
4160 /* Copy all the strictly low elements */
4163 FROMTOUPTO(f2, tp2, t);
4166 FROMTOUPTO(f1, tp2, t);
4172 /* Run out remaining list */
4174 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4175 } else FROMTOUPTO(f1, tp2, l1);
4176 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4181 last = PINDEX(list2, nmemb);
4183 if (base == list2) {
4184 last = PINDEX(list1, nmemb);
4185 FROMTOUPTO(list1, list2, last);
4192 sortcv(pTHX_ SV *a, SV *b)
4194 I32 oldsaveix = PL_savestack_ix;
4195 I32 oldscopeix = PL_scopestack_ix;
4197 GvSV(PL_firstgv) = a;
4198 GvSV(PL_secondgv) = b;
4199 PL_stack_sp = PL_stack_base;
4202 if (PL_stack_sp != PL_stack_base + 1)
4203 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4204 if (!SvNIOKp(*PL_stack_sp))
4205 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4206 result = SvIV(*PL_stack_sp);
4207 while (PL_scopestack_ix > oldscopeix) {
4210 leave_scope(oldsaveix);
4215 sortcv_stacked(pTHX_ SV *a, SV *b)
4217 I32 oldsaveix = PL_savestack_ix;
4218 I32 oldscopeix = PL_scopestack_ix;
4222 #ifdef USE_5005THREADS
4223 av = (AV*)PL_curpad[0];
4225 av = GvAV(PL_defgv);
4228 if (AvMAX(av) < 1) {
4229 SV** ary = AvALLOC(av);
4230 if (AvARRAY(av) != ary) {
4231 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4232 SvPVX(av) = (char*)ary;
4234 if (AvMAX(av) < 1) {
4237 SvPVX(av) = (char*)ary;
4244 PL_stack_sp = PL_stack_base;
4247 if (PL_stack_sp != PL_stack_base + 1)
4248 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4249 if (!SvNIOKp(*PL_stack_sp))
4250 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4251 result = SvIV(*PL_stack_sp);
4252 while (PL_scopestack_ix > oldscopeix) {
4255 leave_scope(oldsaveix);
4260 sortcv_xsub(pTHX_ SV *a, SV *b)
4263 I32 oldsaveix = PL_savestack_ix;
4264 I32 oldscopeix = PL_scopestack_ix;
4266 CV *cv=(CV*)PL_sortcop;
4274 (void)(*CvXSUB(cv))(aTHX_ cv);
4275 if (PL_stack_sp != PL_stack_base + 1)
4276 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4277 if (!SvNIOKp(*PL_stack_sp))
4278 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4279 result = SvIV(*PL_stack_sp);
4280 while (PL_scopestack_ix > oldscopeix) {
4283 leave_scope(oldsaveix);
4289 sv_ncmp(pTHX_ SV *a, SV *b)
4293 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4297 sv_i_ncmp(pTHX_ SV *a, SV *b)
4301 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4303 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4305 if (PL_amagic_generation) { \
4306 if (SvAMAGIC(left)||SvAMAGIC(right))\
4307 *svp = amagic_call(left, \
4315 amagic_ncmp(pTHX_ register SV *a, register SV *b)
4318 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4323 I32 i = SvIVX(tmpsv);
4333 return sv_ncmp(aTHX_ a, b);
4337 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
4340 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4345 I32 i = SvIVX(tmpsv);
4355 return sv_i_ncmp(aTHX_ a, b);
4359 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
4362 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4367 I32 i = SvIVX(tmpsv);
4377 return sv_cmp(str1, str2);
4381 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
4384 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4389 I32 i = SvIVX(tmpsv);
4399 return sv_cmp_locale(str1, str2);
4403 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4405 SV *datasv = FILTER_DATA(idx);
4406 int filter_has_file = IoLINES(datasv);
4407 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4408 SV *filter_state = (SV *)IoTOP_GV(datasv);
4409 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4412 /* I was having segfault trouble under Linux 2.2.5 after a
4413 parse error occured. (Had to hack around it with a test
4414 for PL_error_count == 0.) Solaris doesn't segfault --
4415 not sure where the trouble is yet. XXX */
4417 if (filter_has_file) {
4418 len = FILTER_READ(idx+1, buf_sv, maxlen);
4421 if (filter_sub && len >= 0) {
4432 PUSHs(sv_2mortal(newSViv(maxlen)));
4434 PUSHs(filter_state);
4437 count = call_sv(filter_sub, G_SCALAR);
4453 IoLINES(datasv) = 0;
4454 if (filter_child_proc) {
4455 SvREFCNT_dec(filter_child_proc);
4456 IoFMT_GV(datasv) = Nullgv;
4459 SvREFCNT_dec(filter_state);
4460 IoTOP_GV(datasv) = Nullgv;
4463 SvREFCNT_dec(filter_sub);
4464 IoBOTTOM_GV(datasv) = Nullgv;
4466 filter_del(run_user_filter);