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;
3042 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3043 UV rev = 0, ver = 0, sver = 0;
3045 U8 *s = (U8*)SvPVX(sv);
3046 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3048 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3051 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3054 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3057 if (PERL_REVISION < rev
3058 || (PERL_REVISION == rev
3059 && (PERL_VERSION < ver
3060 || (PERL_VERSION == ver
3061 && PERL_SUBVERSION < sver))))
3063 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3064 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3065 PERL_VERSION, PERL_SUBVERSION);
3067 if (ckWARN(WARN_PORTABLE))
3068 Perl_warner(aTHX_ WARN_PORTABLE,
3069 "v-string in use/require non-portable");
3072 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3073 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3074 + ((NV)PERL_SUBVERSION/(NV)1000000)
3075 + 0.00000099 < SvNV(sv))
3079 NV nver = (nrev - rev) * 1000;
3080 UV ver = (UV)(nver + 0.0009);
3081 NV nsver = (nver - ver) * 1000;
3082 UV sver = (UV)(nsver + 0.0009);
3084 /* help out with the "use 5.6" confusion */
3085 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3086 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3087 "this is only v%d.%d.%d, stopped"
3088 " (did you mean v%"UVuf".%03"UVuf"?)",
3089 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3090 PERL_SUBVERSION, rev, ver/100);
3093 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3094 "this is only v%d.%d.%d, stopped",
3095 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3102 name = SvPV(sv, len);
3103 if (!(name && len > 0 && *name))
3104 DIE(aTHX_ "Null filename used");
3105 TAINT_PROPER("require");
3106 if (PL_op->op_type == OP_REQUIRE &&
3107 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3108 *svp != &PL_sv_undef)
3111 /* prepare to compile file */
3113 #ifdef MACOS_TRADITIONAL
3114 if (PERL_FILE_IS_ABSOLUTE(name)
3115 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3118 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3119 /* We consider paths of the form :a:b ambiguous and interpret them first
3120 as global then as local
3122 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3128 if (PERL_FILE_IS_ABSOLUTE(name)
3129 || (*name == '.' && (name[1] == '/' ||
3130 (name[1] == '.' && name[2] == '/'))))
3133 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3137 AV *ar = GvAVn(PL_incgv);
3141 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3144 namesv = NEWSV(806, 0);
3145 for (i = 0; i <= AvFILL(ar); i++) {
3146 SV *dirsv = *av_fetch(ar, i, TRUE);
3152 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3153 && !sv_isobject(loader))
3155 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3158 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3159 PTR2UV(SvRV(dirsv)), name);
3160 tryname = SvPVX(namesv);
3171 if (sv_isobject(loader))
3172 count = call_method("INC", G_ARRAY);
3174 count = call_sv(loader, G_ARRAY);
3184 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3188 if (SvTYPE(arg) == SVt_PVGV) {
3189 IO *io = GvIO((GV *)arg);
3194 tryrsfp = IoIFP(io);
3195 if (IoTYPE(io) == IoTYPE_PIPE) {
3196 /* reading from a child process doesn't
3197 nest -- when returning from reading
3198 the inner module, the outer one is
3199 unreadable (closed?) I've tried to
3200 save the gv to manage the lifespan of
3201 the pipe, but this didn't help. XXX */
3202 filter_child_proc = (GV *)arg;
3203 (void)SvREFCNT_inc(filter_child_proc);
3206 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3207 PerlIO_close(IoOFP(io));
3219 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3221 (void)SvREFCNT_inc(filter_sub);
3224 filter_state = SP[i];
3225 (void)SvREFCNT_inc(filter_state);
3229 tryrsfp = PerlIO_open("/dev/null",
3244 filter_has_file = 0;
3245 if (filter_child_proc) {
3246 SvREFCNT_dec(filter_child_proc);
3247 filter_child_proc = 0;
3250 SvREFCNT_dec(filter_state);
3254 SvREFCNT_dec(filter_sub);
3259 char *dir = SvPVx(dirsv, n_a);
3260 #ifdef MACOS_TRADITIONAL
3262 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3266 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3268 sv_setpv(namesv, unixdir);
3269 sv_catpv(namesv, unixname);
3271 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3274 TAINT_PROPER("require");
3275 tryname = SvPVX(namesv);
3276 #ifdef MACOS_TRADITIONAL
3278 /* Convert slashes in the name part, but not the directory part, to colons */
3280 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3284 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3286 if (tryname[0] == '.' && tryname[1] == '/')
3294 SAVECOPFILE_FREE(&PL_compiling);
3295 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3296 SvREFCNT_dec(namesv);
3298 if (PL_op->op_type == OP_REQUIRE) {
3299 char *msgstr = name;
3300 if (namesv) { /* did we lookup @INC? */
3301 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3302 SV *dirmsgsv = NEWSV(0, 0);
3303 AV *ar = GvAVn(PL_incgv);
3305 sv_catpvn(msg, " in @INC", 8);
3306 if (instr(SvPVX(msg), ".h "))
3307 sv_catpv(msg, " (change .h to .ph maybe?)");
3308 if (instr(SvPVX(msg), ".ph "))
3309 sv_catpv(msg, " (did you run h2ph?)");
3310 sv_catpv(msg, " (@INC contains:");
3311 for (i = 0; i <= AvFILL(ar); i++) {
3312 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3313 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3314 sv_catsv(msg, dirmsgsv);
3316 sv_catpvn(msg, ")", 1);
3317 SvREFCNT_dec(dirmsgsv);
3318 msgstr = SvPV_nolen(msg);
3320 DIE(aTHX_ "Can't locate %s", msgstr);
3326 SETERRNO(0, SS$_NORMAL);
3328 /* Assume success here to prevent recursive requirement. */
3330 /* Check whether a hook in @INC has already filled %INC */
3331 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3332 (void)hv_store(GvHVn(PL_incgv), name, len,
3333 (hook_sv ? SvREFCNT_inc(hook_sv)
3334 : newSVpv(CopFILE(&PL_compiling), 0)),
3340 lex_start(sv_2mortal(newSVpvn("",0)));
3341 SAVEGENERICSV(PL_rsfp_filters);
3342 PL_rsfp_filters = Nullav;
3347 SAVESPTR(PL_compiling.cop_warnings);
3348 if (PL_dowarn & G_WARN_ALL_ON)
3349 PL_compiling.cop_warnings = pWARN_ALL ;
3350 else if (PL_dowarn & G_WARN_ALL_OFF)
3351 PL_compiling.cop_warnings = pWARN_NONE ;
3353 PL_compiling.cop_warnings = pWARN_STD ;
3354 SAVESPTR(PL_compiling.cop_io);
3355 PL_compiling.cop_io = Nullsv;
3357 if (filter_sub || filter_child_proc) {
3358 SV *datasv = filter_add(run_user_filter, Nullsv);
3359 IoLINES(datasv) = filter_has_file;
3360 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3361 IoTOP_GV(datasv) = (GV *)filter_state;
3362 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3365 /* switch to eval mode */
3366 push_return(PL_op->op_next);
3367 PUSHBLOCK(cx, CXt_EVAL, SP);
3368 PUSHEVAL(cx, name, Nullgv);
3370 SAVECOPLINE(&PL_compiling);
3371 CopLINE_set(&PL_compiling, 0);
3374 #ifdef USE_5005THREADS
3375 MUTEX_LOCK(&PL_eval_mutex);
3376 if (PL_eval_owner && PL_eval_owner != thr)
3377 while (PL_eval_owner)
3378 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3379 PL_eval_owner = thr;
3380 MUTEX_UNLOCK(&PL_eval_mutex);
3381 #endif /* USE_5005THREADS */
3382 return DOCATCH(doeval(gimme, NULL));
3387 return pp_require();
3393 register PERL_CONTEXT *cx;
3395 I32 gimme = GIMME_V, was = PL_sub_generation;
3396 char tbuf[TYPE_DIGITS(long) + 12];
3397 char *tmpbuf = tbuf;
3402 if (!SvPV(sv,len) || !len)
3404 TAINT_PROPER("eval");
3410 /* switch to eval mode */
3412 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3413 SV *sv = sv_newmortal();
3414 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3415 (unsigned long)++PL_evalseq,
3416 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3420 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3421 SAVECOPFILE_FREE(&PL_compiling);
3422 CopFILE_set(&PL_compiling, tmpbuf+2);
3423 SAVECOPLINE(&PL_compiling);
3424 CopLINE_set(&PL_compiling, 1);
3425 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3426 deleting the eval's FILEGV from the stash before gv_check() runs
3427 (i.e. before run-time proper). To work around the coredump that
3428 ensues, we always turn GvMULTI_on for any globals that were
3429 introduced within evals. See force_ident(). GSAR 96-10-12 */
3430 safestr = savepv(tmpbuf);
3431 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3433 PL_hints = PL_op->op_targ;
3434 SAVESPTR(PL_compiling.cop_warnings);
3435 if (specialWARN(PL_curcop->cop_warnings))
3436 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3438 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3439 SAVEFREESV(PL_compiling.cop_warnings);
3441 SAVESPTR(PL_compiling.cop_io);
3442 if (specialCopIO(PL_curcop->cop_io))
3443 PL_compiling.cop_io = PL_curcop->cop_io;
3445 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3446 SAVEFREESV(PL_compiling.cop_io);
3449 push_return(PL_op->op_next);
3450 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3451 PUSHEVAL(cx, 0, Nullgv);
3453 /* prepare to compile string */
3455 if (PERLDB_LINE && PL_curstash != PL_debstash)
3456 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3458 #ifdef USE_5005THREADS
3459 MUTEX_LOCK(&PL_eval_mutex);
3460 if (PL_eval_owner && PL_eval_owner != thr)
3461 while (PL_eval_owner)
3462 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3463 PL_eval_owner = thr;
3464 MUTEX_UNLOCK(&PL_eval_mutex);
3465 #endif /* USE_5005THREADS */
3466 ret = doeval(gimme, NULL);
3467 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3468 && ret != PL_op->op_next) { /* Successive compilation. */
3469 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3471 return DOCATCH(ret);
3481 register PERL_CONTEXT *cx;
3483 U8 save_flags = PL_op -> op_flags;
3488 retop = pop_return();
3491 if (gimme == G_VOID)
3493 else if (gimme == G_SCALAR) {
3496 if (SvFLAGS(TOPs) & SVs_TEMP)
3499 *MARK = sv_mortalcopy(TOPs);
3503 *MARK = &PL_sv_undef;
3508 /* in case LEAVE wipes old return values */
3509 for (mark = newsp + 1; mark <= SP; mark++) {
3510 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3511 *mark = sv_mortalcopy(*mark);
3512 TAINT_NOT; /* Each item is independent */
3516 PL_curpm = newpm; /* Don't pop $1 et al till now */
3519 assert(CvDEPTH(PL_compcv) == 1);
3521 CvDEPTH(PL_compcv) = 0;
3524 if (optype == OP_REQUIRE &&
3525 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3527 /* Unassume the success we assumed earlier. */
3528 SV *nsv = cx->blk_eval.old_namesv;
3529 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3530 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3531 /* die_where() did LEAVE, or we won't be here */
3535 if (!(save_flags & OPf_SPECIAL))
3545 register PERL_CONTEXT *cx;
3546 I32 gimme = GIMME_V;
3551 push_return(cLOGOP->op_other->op_next);
3552 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3555 PL_in_eval = EVAL_INEVAL;
3558 return DOCATCH(PL_op->op_next);
3568 register PERL_CONTEXT *cx;
3576 if (gimme == G_VOID)
3578 else if (gimme == G_SCALAR) {
3581 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3584 *MARK = sv_mortalcopy(TOPs);
3588 *MARK = &PL_sv_undef;
3593 /* in case LEAVE wipes old return values */
3594 for (mark = newsp + 1; mark <= SP; mark++) {
3595 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3596 *mark = sv_mortalcopy(*mark);
3597 TAINT_NOT; /* Each item is independent */
3601 PL_curpm = newpm; /* Don't pop $1 et al till now */
3609 S_doparseform(pTHX_ SV *sv)
3612 register char *s = SvPV_force(sv, len);
3613 register char *send = s + len;
3614 register char *base = Nullch;
3615 register I32 skipspaces = 0;
3616 bool noblank = FALSE;
3617 bool repeat = FALSE;
3618 bool postspace = FALSE;
3626 Perl_croak(aTHX_ "Null picture in formline");
3628 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3633 *fpc++ = FF_LINEMARK;
3634 noblank = repeat = FALSE;
3652 case ' ': case '\t':
3663 *fpc++ = FF_LITERAL;
3671 *fpc++ = skipspaces;
3675 *fpc++ = FF_NEWLINE;
3679 arg = fpc - linepc + 1;
3686 *fpc++ = FF_LINEMARK;
3687 noblank = repeat = FALSE;
3696 ischop = s[-1] == '^';
3702 arg = (s - base) - 1;
3704 *fpc++ = FF_LITERAL;
3713 *fpc++ = FF_LINEGLOB;
3715 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3716 arg = ischop ? 512 : 0;
3726 arg |= 256 + (s - f);
3728 *fpc++ = s - base; /* fieldsize for FETCH */
3729 *fpc++ = FF_DECIMAL;
3732 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3733 arg = ischop ? 512 : 0;
3735 s++; /* skip the '0' first */
3744 arg |= 256 + (s - f);
3746 *fpc++ = s - base; /* fieldsize for FETCH */
3747 *fpc++ = FF_0DECIMAL;
3752 bool ismore = FALSE;
3755 while (*++s == '>') ;
3756 prespace = FF_SPACE;
3758 else if (*s == '|') {
3759 while (*++s == '|') ;
3760 prespace = FF_HALFSPACE;
3765 while (*++s == '<') ;
3768 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3772 *fpc++ = s - base; /* fieldsize for FETCH */
3774 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3792 { /* need to jump to the next word */
3794 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3795 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3796 s = SvPVX(sv) + SvCUR(sv) + z;
3798 Copy(fops, s, arg, U16);
3800 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3805 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3807 * The original code was written in conjunction with BSD Computer Software
3808 * Research Group at University of California, Berkeley.
3810 * See also: "Optimistic Merge Sort" (SODA '92)
3812 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3814 * The code can be distributed under the same terms as Perl itself.
3819 #include <sys/types.h>
3823 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3824 #define Safefree(VAR) free(VAR)
3825 typedef int (*SVCOMPARE_t) (pTHX_ SV*, SV*);
3826 #endif /* TESTHARNESS */
3828 typedef char * aptr; /* pointer for arithmetic on sizes */
3829 typedef SV * gptr; /* pointers in our lists */
3831 /* Binary merge internal sort, with a few special mods
3832 ** for the special perl environment it now finds itself in.
3834 ** Things that were once options have been hotwired
3835 ** to values suitable for this use. In particular, we'll always
3836 ** initialize looking for natural runs, we'll always produce stable
3837 ** output, and we'll always do Peter McIlroy's binary merge.
3840 /* Pointer types for arithmetic and storage and convenience casts */
3842 #define APTR(P) ((aptr)(P))
3843 #define GPTP(P) ((gptr *)(P))
3844 #define GPPP(P) ((gptr **)(P))
3847 /* byte offset from pointer P to (larger) pointer Q */
3848 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3850 #define PSIZE sizeof(gptr)
3852 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3855 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3856 #define PNBYTE(N) ((N) << (PSHIFT))
3857 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3859 /* Leave optimization to compiler */
3860 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3861 #define PNBYTE(N) ((N) * (PSIZE))
3862 #define PINDEX(P, N) (GPTP(P) + (N))
3865 /* Pointer into other corresponding to pointer into this */
3866 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3868 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3871 /* Runs are identified by a pointer in the auxilliary list.
3872 ** The pointer is at the start of the list,
3873 ** and it points to the start of the next list.
3874 ** NEXT is used as an lvalue, too.
3877 #define NEXT(P) (*GPPP(P))
3880 /* PTHRESH is the minimum number of pairs with the same sense to justify
3881 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3882 ** not just elements, so PTHRESH == 8 means a run of 16.
3887 /* RTHRESH is the number of elements in a run that must compare low
3888 ** to the low element from the opposing run before we justify
3889 ** doing a binary rampup instead of single stepping.
3890 ** In random input, N in a row low should only happen with
3891 ** probability 2^(1-N), so we can risk that we are dealing
3892 ** with orderly input without paying much when we aren't.
3899 ** Overview of algorithm and variables.
3900 ** The array of elements at list1 will be organized into runs of length 2,
3901 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3902 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3904 ** Unless otherwise specified, pair pointers address the first of two elements.
3906 ** b and b+1 are a pair that compare with sense ``sense''.
3907 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3909 ** p2 parallels b in the list2 array, where runs are defined by
3912 ** t represents the ``top'' of the adjacent pairs that might extend
3913 ** the run beginning at b. Usually, t addresses a pair
3914 ** that compares with opposite sense from (b,b+1).
3915 ** However, it may also address a singleton element at the end of list1,
3916 ** or it may be equal to ``last'', the first element beyond list1.
3918 ** r addresses the Nth pair following b. If this would be beyond t,
3919 ** we back it off to t. Only when r is less than t do we consider the
3920 ** run long enough to consider checking.
3922 ** q addresses a pair such that the pairs at b through q already form a run.
3923 ** Often, q will equal b, indicating we only are sure of the pair itself.
3924 ** However, a search on the previous cycle may have revealed a longer run,
3925 ** so q may be greater than b.
3927 ** p is used to work back from a candidate r, trying to reach q,
3928 ** which would mean b through r would be a run. If we discover such a run,
3929 ** we start q at r and try to push it further towards t.
3930 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3931 ** In any event, after the check (if any), we have two main cases.
3933 ** 1) Short run. b <= q < p <= r <= t.
3934 ** b through q is a run (perhaps trivial)
3935 ** q through p are uninteresting pairs
3936 ** p through r is a run
3938 ** 2) Long run. b < r <= q < t.
3939 ** b through q is a run (of length >= 2 * PTHRESH)
3941 ** Note that degenerate cases are not only possible, but likely.
3942 ** For example, if the pair following b compares with opposite sense,
3943 ** then b == q < p == r == t.
3948 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3951 register gptr *b, *p, *q, *t, *p2;
3952 register gptr c, *last, *r;
3956 last = PINDEX(b, nmemb);
3957 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3958 for (p2 = list2; b < last; ) {
3959 /* We just started, or just reversed sense.
3960 ** Set t at end of pairs with the prevailing sense.
3962 for (p = b+2, t = p; ++p < last; t = ++p) {
3963 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3966 /* Having laid out the playing field, look for long runs */
3968 p = r = b + (2 * PTHRESH);
3969 if (r >= t) p = r = t; /* too short to care about */
3971 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3974 /* b through r is a (long) run.
3975 ** Extend it as far as possible.
3978 while (((p += 2) < t) &&
3979 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3980 r = p = q + 2; /* no simple pairs, no after-run */
3983 if (q > b) { /* run of greater than 2 at b */
3986 /* pick up singleton, if possible */
3988 ((t + 1) == last) &&
3989 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3990 savep = r = p = q = last;
3991 p2 = NEXT(p2) = p2 + (p - b);
3992 if (sense) while (b < --p) {
3999 while (q < p) { /* simple pairs */
4000 p2 = NEXT(p2) = p2 + 2;
4007 if (((b = p) == t) && ((t+1) == last)) {
4019 /* Overview of bmerge variables:
4021 ** list1 and list2 address the main and auxiliary arrays.
4022 ** They swap identities after each merge pass.
4023 ** Base points to the original list1, so we can tell if
4024 ** the pointers ended up where they belonged (or must be copied).
4026 ** When we are merging two lists, f1 and f2 are the next elements
4027 ** on the respective lists. l1 and l2 mark the end of the lists.
4028 ** tp2 is the current location in the merged list.
4030 ** p1 records where f1 started.
4031 ** After the merge, a new descriptor is built there.
4033 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4034 ** It is used to identify and delimit the runs.
4036 ** In the heat of determining where q, the greater of the f1/f2 elements,
4037 ** belongs in the other list, b, t and p, represent bottom, top and probe
4038 ** locations, respectively, in the other list.
4039 ** They make convenient temporary pointers in other places.
4045 Sort an array. Here is an example:
4047 sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
4053 Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4057 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4058 gptr *aux, *list2, *p2, *last;
4062 if (nmemb <= 1) return; /* sorted trivially */
4063 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4065 dynprep(aTHX_ list1, list2, nmemb, cmp);
4066 last = PINDEX(list2, nmemb);
4067 while (NEXT(list2) != last) {
4068 /* More than one run remains. Do some merging to reduce runs. */
4070 for (tp2 = p2 = list2; p2 != last;) {
4071 /* The new first run begins where the old second list ended.
4072 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4076 f2 = l1 = POTHER(t, list2, list1);
4077 if (t != last) t = NEXT(t);
4078 l2 = POTHER(t, list2, list1);
4080 while (f1 < l1 && f2 < l2) {
4081 /* If head 1 is larger than head 2, find ALL the elements
4082 ** in list 2 strictly less than head1, write them all,
4083 ** then head 1. Then compare the new heads, and repeat,
4084 ** until one or both lists are exhausted.
4086 ** In all comparisons (after establishing
4087 ** which head to merge) the item to merge
4088 ** (at pointer q) is the first operand of
4089 ** the comparison. When we want to know
4090 ** if ``q is strictly less than the other'',
4092 ** cmp(q, other) < 0
4093 ** because stability demands that we treat equality
4094 ** as high when q comes from l2, and as low when
4095 ** q was from l1. So we ask the question by doing
4096 ** cmp(q, other) <= sense
4097 ** and make sense == 0 when equality should look low,
4098 ** and -1 when equality should look high.
4102 if (cmp(aTHX_ *f1, *f2) <= 0) {
4103 q = f2; b = f1; t = l1;
4106 q = f1; b = f2; t = l2;
4113 ** Leave t at something strictly
4114 ** greater than q (or at the end of the list),
4115 ** and b at something strictly less than q.
4117 for (i = 1, run = 0 ;;) {
4118 if ((p = PINDEX(b, i)) >= t) {
4120 if (((p = PINDEX(t, -1)) > b) &&
4121 (cmp(aTHX_ *q, *p) <= sense))
4125 } else if (cmp(aTHX_ *q, *p) <= sense) {
4129 if (++run >= RTHRESH) i += i;
4133 /* q is known to follow b and must be inserted before t.
4134 ** Increment b, so the range of possibilities is [b,t).
4135 ** Round binary split down, to favor early appearance.
4136 ** Adjust b and t until q belongs just before t.
4141 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4142 if (cmp(aTHX_ *q, *p) <= sense) {
4148 /* Copy all the strictly low elements */
4151 FROMTOUPTO(f2, tp2, t);
4154 FROMTOUPTO(f1, tp2, t);
4160 /* Run out remaining list */
4162 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4163 } else FROMTOUPTO(f1, tp2, l1);
4164 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4169 last = PINDEX(list2, nmemb);
4171 if (base == list2) {
4172 last = PINDEX(list1, nmemb);
4173 FROMTOUPTO(list1, list2, last);
4180 sortcv(pTHX_ SV *a, SV *b)
4182 I32 oldsaveix = PL_savestack_ix;
4183 I32 oldscopeix = PL_scopestack_ix;
4185 GvSV(PL_firstgv) = a;
4186 GvSV(PL_secondgv) = b;
4187 PL_stack_sp = PL_stack_base;
4190 if (PL_stack_sp != PL_stack_base + 1)
4191 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4192 if (!SvNIOKp(*PL_stack_sp))
4193 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4194 result = SvIV(*PL_stack_sp);
4195 while (PL_scopestack_ix > oldscopeix) {
4198 leave_scope(oldsaveix);
4203 sortcv_stacked(pTHX_ SV *a, SV *b)
4205 I32 oldsaveix = PL_savestack_ix;
4206 I32 oldscopeix = PL_scopestack_ix;
4210 #ifdef USE_5005THREADS
4211 av = (AV*)PL_curpad[0];
4213 av = GvAV(PL_defgv);
4216 if (AvMAX(av) < 1) {
4217 SV** ary = AvALLOC(av);
4218 if (AvARRAY(av) != ary) {
4219 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4220 SvPVX(av) = (char*)ary;
4222 if (AvMAX(av) < 1) {
4225 SvPVX(av) = (char*)ary;
4232 PL_stack_sp = PL_stack_base;
4235 if (PL_stack_sp != PL_stack_base + 1)
4236 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4237 if (!SvNIOKp(*PL_stack_sp))
4238 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4239 result = SvIV(*PL_stack_sp);
4240 while (PL_scopestack_ix > oldscopeix) {
4243 leave_scope(oldsaveix);
4248 sortcv_xsub(pTHX_ SV *a, SV *b)
4251 I32 oldsaveix = PL_savestack_ix;
4252 I32 oldscopeix = PL_scopestack_ix;
4254 CV *cv=(CV*)PL_sortcop;
4262 (void)(*CvXSUB(cv))(aTHX_ cv);
4263 if (PL_stack_sp != PL_stack_base + 1)
4264 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4265 if (!SvNIOKp(*PL_stack_sp))
4266 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4267 result = SvIV(*PL_stack_sp);
4268 while (PL_scopestack_ix > oldscopeix) {
4271 leave_scope(oldsaveix);
4277 sv_ncmp(pTHX_ SV *a, SV *b)
4281 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4285 sv_i_ncmp(pTHX_ SV *a, SV *b)
4289 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4291 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4293 if (PL_amagic_generation) { \
4294 if (SvAMAGIC(left)||SvAMAGIC(right))\
4295 *svp = amagic_call(left, \
4303 amagic_ncmp(pTHX_ register SV *a, register SV *b)
4306 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4311 I32 i = SvIVX(tmpsv);
4321 return sv_ncmp(aTHX_ a, b);
4325 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
4328 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4333 I32 i = SvIVX(tmpsv);
4343 return sv_i_ncmp(aTHX_ a, b);
4347 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
4350 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4355 I32 i = SvIVX(tmpsv);
4365 return sv_cmp(str1, str2);
4369 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
4372 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4377 I32 i = SvIVX(tmpsv);
4387 return sv_cmp_locale(str1, str2);
4391 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4393 SV *datasv = FILTER_DATA(idx);
4394 int filter_has_file = IoLINES(datasv);
4395 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4396 SV *filter_state = (SV *)IoTOP_GV(datasv);
4397 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4400 /* I was having segfault trouble under Linux 2.2.5 after a
4401 parse error occured. (Had to hack around it with a test
4402 for PL_error_count == 0.) Solaris doesn't segfault --
4403 not sure where the trouble is yet. XXX */
4405 if (filter_has_file) {
4406 len = FILTER_READ(idx+1, buf_sv, maxlen);
4409 if (filter_sub && len >= 0) {
4420 PUSHs(sv_2mortal(newSViv(maxlen)));
4422 PUSHs(filter_state);
4425 count = call_sv(filter_sub, G_SCALAR);
4441 IoLINES(datasv) = 0;
4442 if (filter_child_proc) {
4443 SvREFCNT_dec(filter_child_proc);
4444 IoFMT_GV(datasv) = Nullgv;
4447 SvREFCNT_dec(filter_state);
4448 IoTOP_GV(datasv) = Nullgv;
4451 SvREFCNT_dec(filter_sub);
4452 IoBOTTOM_GV(datasv) = Nullgv;
4454 filter_del(run_user_filter);