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(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 /* prevent recompiling under /o and ithreads. */
93 #if defined(USE_ITHREADS) || defined(USE_THREADS)
94 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
99 SV *sv = SvRV(tmpstr);
101 mg = mg_find(sv, PERL_MAGIC_qr);
104 regexp *re = (regexp *)mg->mg_obj;
105 ReREFCNT_dec(PM_GETRE(pm));
106 PM_SETRE(pm, ReREFCNT_inc(re));
109 t = SvPV(tmpstr, len);
111 /* Check against the last compiled regexp. */
112 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
113 PM_GETRE(pm)->prelen != len ||
114 memNE(PM_GETRE(pm)->precomp, t, len))
117 ReREFCNT_dec(PM_GETRE(pm));
118 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
120 if (PL_op->op_flags & OPf_SPECIAL)
121 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
123 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
125 pm->op_pmdynflags |= PMdf_DYN_UTF8;
127 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
128 if (pm->op_pmdynflags & PMdf_UTF8)
129 t = (char*)bytes_to_utf8((U8*)t, &len);
131 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
132 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
134 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
135 inside tie/overload accessors. */
139 #ifndef INCOMPLETE_TAINTS
142 pm->op_pmdynflags |= PMdf_TAINTED;
144 pm->op_pmdynflags &= ~PMdf_TAINTED;
148 if (!PM_GETRE(pm)->prelen && PL_curpm)
151 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
152 pm->op_pmflags |= PMf_WHITE;
154 pm->op_pmflags &= ~PMf_WHITE;
156 /* XXX runtime compiled output needs to move to the pad */
157 if (pm->op_pmflags & PMf_KEEP) {
158 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
159 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
160 /* XXX can't change the optree at runtime either */
161 cLOGOP->op_first->op_next = PL_op->op_next;
170 register PMOP *pm = (PMOP*) cLOGOP->op_other;
171 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
172 register SV *dstr = cx->sb_dstr;
173 register char *s = cx->sb_s;
174 register char *m = cx->sb_m;
175 char *orig = cx->sb_orig;
176 register REGEXP *rx = cx->sb_rx;
178 rxres_restore(&cx->sb_rxres, rx);
180 if (cx->sb_iters++) {
181 if (cx->sb_iters > cx->sb_maxiters)
182 DIE(aTHX_ "Substitution loop");
184 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
185 cx->sb_rxtainted |= 2;
186 sv_catsv(dstr, POPs);
189 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
190 s == m, cx->sb_targ, NULL,
191 ((cx->sb_rflags & REXEC_COPY_STR)
192 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
193 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
195 SV *targ = cx->sb_targ;
197 sv_catpvn(dstr, s, cx->sb_strend - s);
198 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
200 (void)SvOOK_off(targ);
201 Safefree(SvPVX(targ));
202 SvPVX(targ) = SvPVX(dstr);
203 SvCUR_set(targ, SvCUR(dstr));
204 SvLEN_set(targ, SvLEN(dstr));
210 TAINT_IF(cx->sb_rxtainted & 1);
211 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
213 (void)SvPOK_only_UTF8(targ);
214 TAINT_IF(cx->sb_rxtainted);
218 LEAVE_SCOPE(cx->sb_oldsave);
220 RETURNOP(pm->op_next);
223 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
226 cx->sb_orig = orig = rx->subbeg;
228 cx->sb_strend = s + (cx->sb_strend - m);
230 cx->sb_m = m = rx->startp[0] + orig;
232 sv_catpvn(dstr, s, m-s);
233 cx->sb_s = rx->endp[0] + orig;
234 { /* Update the pos() information. */
235 SV *sv = cx->sb_targ;
238 if (SvTYPE(sv) < SVt_PVMG)
239 (void)SvUPGRADE(sv, SVt_PVMG);
240 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
241 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
242 mg = mg_find(sv, PERL_MAGIC_regex_global);
249 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
250 rxres_save(&cx->sb_rxres, rx);
251 RETURNOP(pm->op_pmreplstart);
255 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
260 if (!p || p[1] < rx->nparens) {
261 i = 6 + rx->nparens * 2;
269 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
270 RX_MATCH_COPIED_off(rx);
274 *p++ = PTR2UV(rx->subbeg);
275 *p++ = (UV)rx->sublen;
276 for (i = 0; i <= rx->nparens; ++i) {
277 *p++ = (UV)rx->startp[i];
278 *p++ = (UV)rx->endp[i];
283 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
288 if (RX_MATCH_COPIED(rx))
289 Safefree(rx->subbeg);
290 RX_MATCH_COPIED_set(rx, *p);
295 rx->subbeg = INT2PTR(char*,*p++);
296 rx->sublen = (I32)(*p++);
297 for (i = 0; i <= rx->nparens; ++i) {
298 rx->startp[i] = (I32)(*p++);
299 rx->endp[i] = (I32)(*p++);
304 Perl_rxres_free(pTHX_ void **rsp)
309 Safefree(INT2PTR(char*,*p));
317 dSP; dMARK; dORIGMARK;
318 register SV *tmpForm = *++MARK;
325 register SV *sv = Nullsv;
330 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
331 char *chophere = Nullch;
332 char *linemark = Nullch;
334 bool gotsome = FALSE;
336 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
337 bool item_is_utf = FALSE;
339 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
340 if (SvREADONLY(tmpForm)) {
341 SvREADONLY_off(tmpForm);
342 doparseform(tmpForm);
343 SvREADONLY_on(tmpForm);
346 doparseform(tmpForm);
349 SvPV_force(PL_formtarget, len);
350 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
352 f = SvPV(tmpForm, len);
353 /* need to jump to the next word */
354 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
363 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
364 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
365 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
366 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
367 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
369 case FF_CHECKNL: name = "CHECKNL"; break;
370 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
371 case FF_SPACE: name = "SPACE"; break;
372 case FF_HALFSPACE: name = "HALFSPACE"; break;
373 case FF_ITEM: name = "ITEM"; break;
374 case FF_CHOP: name = "CHOP"; break;
375 case FF_LINEGLOB: name = "LINEGLOB"; break;
376 case FF_NEWLINE: name = "NEWLINE"; break;
377 case FF_MORE: name = "MORE"; break;
378 case FF_LINEMARK: name = "LINEMARK"; break;
379 case FF_END: name = "END"; break;
380 case FF_0DECIMAL: name = "0DECIMAL"; break;
383 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
385 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
413 if (ckWARN(WARN_SYNTAX))
414 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
419 item = s = SvPV(sv, len);
422 itemsize = sv_len_utf8(sv);
423 if (itemsize != len) {
425 if (itemsize > fieldsize) {
426 itemsize = fieldsize;
427 itembytes = itemsize;
428 sv_pos_u2b(sv, &itembytes, 0);
432 send = chophere = s + itembytes;
442 sv_pos_b2u(sv, &itemsize);
447 if (itemsize > fieldsize)
448 itemsize = fieldsize;
449 send = chophere = s + itemsize;
461 item = s = SvPV(sv, len);
464 itemsize = sv_len_utf8(sv);
465 if (itemsize != len) {
467 if (itemsize <= fieldsize) {
468 send = chophere = s + itemsize;
479 itemsize = fieldsize;
480 itembytes = itemsize;
481 sv_pos_u2b(sv, &itembytes, 0);
482 send = chophere = s + itembytes;
483 while (s < send || (s == send && isSPACE(*s))) {
493 if (strchr(PL_chopset, *s))
498 itemsize = chophere - item;
499 sv_pos_b2u(sv, &itemsize);
506 if (itemsize <= fieldsize) {
507 send = chophere = s + itemsize;
518 itemsize = fieldsize;
519 send = chophere = s + itemsize;
520 while (s < send || (s == send && isSPACE(*s))) {
530 if (strchr(PL_chopset, *s))
535 itemsize = chophere - item;
540 arg = fieldsize - itemsize;
549 arg = fieldsize - itemsize;
563 if (UTF8_IS_CONTINUED(*s)) {
564 STRLEN skip = UTF8SKIP(s);
581 if ( !((*t++ = *s++) & ~31) )
589 int ch = *t++ = *s++;
592 if ( !((*t++ = *s++) & ~31) )
601 while (*s && isSPACE(*s))
608 item = s = SvPV(sv, len);
610 item_is_utf = FALSE; /* XXX is this correct? */
622 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
623 sv_catpvn(PL_formtarget, item, itemsize);
624 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
625 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
630 /* If the field is marked with ^ and the value is undefined,
633 if ((arg & 512) && !SvOK(sv)) {
641 /* Formats aren't yet marked for locales, so assume "yes". */
643 STORE_NUMERIC_STANDARD_SET_LOCAL();
644 #if defined(USE_LONG_DOUBLE)
646 sprintf(t, "%#*.*" PERL_PRIfldbl,
647 (int) fieldsize, (int) arg & 255, value);
649 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
654 (int) fieldsize, (int) arg & 255, value);
657 (int) fieldsize, value);
660 RESTORE_NUMERIC_STANDARD();
666 /* If the field is marked with ^ and the value is undefined,
669 if ((arg & 512) && !SvOK(sv)) {
677 /* Formats aren't yet marked for locales, so assume "yes". */
679 STORE_NUMERIC_STANDARD_SET_LOCAL();
680 #if defined(USE_LONG_DOUBLE)
682 sprintf(t, "%#0*.*" PERL_PRIfldbl,
683 (int) fieldsize, (int) arg & 255, value);
684 /* is this legal? I don't have long doubles */
686 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
690 sprintf(t, "%#0*.*f",
691 (int) fieldsize, (int) arg & 255, value);
694 (int) fieldsize, value);
697 RESTORE_NUMERIC_STANDARD();
704 while (t-- > linemark && *t == ' ') ;
712 if (arg) { /* repeat until fields exhausted? */
714 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
715 lines += FmLINES(PL_formtarget);
718 if (strnEQ(linemark, linemark - arg, arg))
719 DIE(aTHX_ "Runaway format");
721 FmLINES(PL_formtarget) = lines;
723 RETURNOP(cLISTOP->op_first);
736 while (*s && isSPACE(*s) && s < send)
740 arg = fieldsize - itemsize;
747 if (strnEQ(s," ",3)) {
748 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
759 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
760 FmLINES(PL_formtarget) += lines;
772 if (PL_stack_base + *PL_markstack_ptr == SP) {
774 if (GIMME_V == G_SCALAR)
775 XPUSHs(sv_2mortal(newSViv(0)));
776 RETURNOP(PL_op->op_next->op_next);
778 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
779 pp_pushmark(); /* push dst */
780 pp_pushmark(); /* push src */
781 ENTER; /* enter outer scope */
784 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
786 ENTER; /* enter inner scope */
789 src = PL_stack_base[*PL_markstack_ptr];
794 if (PL_op->op_type == OP_MAPSTART)
795 pp_pushmark(); /* push top */
796 return ((LOGOP*)PL_op->op_next)->op_other;
801 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
807 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
813 /* first, move source pointer to the next item in the source list */
814 ++PL_markstack_ptr[-1];
816 /* if there are new items, push them into the destination list */
818 /* might need to make room back there first */
819 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
820 /* XXX this implementation is very pessimal because the stack
821 * is repeatedly extended for every set of items. Is possible
822 * to do this without any stack extension or copying at all
823 * by maintaining a separate list over which the map iterates
824 * (like foreach does). --gsar */
826 /* everything in the stack after the destination list moves
827 * towards the end the stack by the amount of room needed */
828 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
830 /* items to shift up (accounting for the moved source pointer) */
831 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
833 /* This optimization is by Ben Tilly and it does
834 * things differently from what Sarathy (gsar)
835 * is describing. The downside of this optimization is
836 * that leaves "holes" (uninitialized and hopefully unused areas)
837 * to the Perl stack, but on the other hand this
838 * shouldn't be a problem. If Sarathy's idea gets
839 * implemented, this optimization should become
840 * irrelevant. --jhi */
842 shift = count; /* Avoid shifting too often --Ben Tilly */
847 PL_markstack_ptr[-1] += shift;
848 *PL_markstack_ptr += shift;
852 /* copy the new items down to the destination list */
853 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
855 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
857 LEAVE; /* exit inner scope */
860 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
863 (void)POPMARK; /* pop top */
864 LEAVE; /* exit outer scope */
865 (void)POPMARK; /* pop src */
866 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
867 (void)POPMARK; /* pop dst */
868 SP = PL_stack_base + POPMARK; /* pop original mark */
869 if (gimme == G_SCALAR) {
873 else if (gimme == G_ARRAY)
880 ENTER; /* enter inner scope */
883 /* set $_ to the new source item */
884 src = PL_stack_base[PL_markstack_ptr[-1]];
888 RETURNOP(cLOGOP->op_other);
894 dSP; dMARK; dORIGMARK;
896 SV **myorigmark = ORIGMARK;
902 OP* nextop = PL_op->op_next;
904 bool hasargs = FALSE;
907 if (gimme != G_ARRAY) {
913 SAVEVPTR(PL_sortcop);
914 if (PL_op->op_flags & OPf_STACKED) {
915 if (PL_op->op_flags & OPf_SPECIAL) {
916 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
917 kid = kUNOP->op_first; /* pass rv2gv */
918 kid = kUNOP->op_first; /* pass leave */
919 PL_sortcop = kid->op_next;
920 stash = CopSTASH(PL_curcop);
923 cv = sv_2cv(*++MARK, &stash, &gv, 0);
924 if (cv && SvPOK(cv)) {
926 char *proto = SvPV((SV*)cv, n_a);
927 if (proto && strEQ(proto, "$$")) {
931 if (!(cv && CvROOT(cv))) {
932 if (cv && CvXSUB(cv)) {
936 SV *tmpstr = sv_newmortal();
937 gv_efullname3(tmpstr, gv, Nullch);
938 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
942 DIE(aTHX_ "Undefined subroutine in sort");
947 PL_sortcop = (OP*)cv;
949 PL_sortcop = CvSTART(cv);
950 SAVEVPTR(CvROOT(cv)->op_ppaddr);
951 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
954 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
960 stash = CopSTASH(PL_curcop);
964 while (MARK < SP) { /* This may or may not shift down one here. */
966 if ((*up = *++MARK)) { /* Weed out nulls. */
968 if (!PL_sortcop && !SvPOK(*up)) {
973 (void)sv_2pv(*up, &n_a);
978 max = --up - myorigmark;
983 bool oldcatch = CATCH_GET;
989 PUSHSTACKi(PERLSI_SORT);
990 if (!hasargs && !is_xsub) {
991 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
992 SAVESPTR(PL_firstgv);
993 SAVESPTR(PL_secondgv);
994 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
995 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
996 PL_sortstash = stash;
999 sv_lock((SV *)PL_firstgv);
1000 sv_lock((SV *)PL_secondgv);
1002 SAVESPTR(GvSV(PL_firstgv));
1003 SAVESPTR(GvSV(PL_secondgv));
1006 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1007 if (!(PL_op->op_flags & OPf_SPECIAL)) {
1008 cx->cx_type = CXt_SUB;
1009 cx->blk_gimme = G_SCALAR;
1012 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1014 PL_sortcxix = cxstack_ix;
1016 if (hasargs && !is_xsub) {
1017 /* This is mostly copied from pp_entersub */
1018 AV *av = (AV*)PL_curpad[0];
1021 cx->blk_sub.savearray = GvAV(PL_defgv);
1022 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1023 #endif /* USE_THREADS */
1024 cx->blk_sub.oldcurpad = PL_curpad;
1025 cx->blk_sub.argarray = av;
1027 qsortsv((myorigmark+1), max,
1028 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1030 POPBLOCK(cx,PL_curpm);
1031 PL_stack_sp = newsp;
1033 CATCH_SET(oldcatch);
1038 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1039 qsortsv(ORIGMARK+1, max,
1040 (PL_op->op_private & OPpSORT_NUMERIC)
1041 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1042 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1043 : ( overloading ? amagic_ncmp : sv_ncmp))
1044 : ( IN_LOCALE_RUNTIME
1047 : sv_cmp_locale_static)
1048 : ( overloading ? amagic_cmp : sv_cmp_static)));
1049 if (PL_op->op_private & OPpSORT_REVERSE) {
1050 SV **p = ORIGMARK+1;
1051 SV **q = ORIGMARK+max;
1061 PL_stack_sp = ORIGMARK + max;
1069 if (GIMME == G_ARRAY)
1071 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1072 return cLOGOP->op_other;
1081 if (GIMME == G_ARRAY) {
1082 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1086 SV *targ = PAD_SV(PL_op->op_targ);
1089 if (PL_op->op_private & OPpFLIP_LINENUM) {
1091 flip = PL_last_in_gv
1092 && (gp_io = GvIO(PL_last_in_gv))
1093 && SvIV(sv) == (IV)IoLINES(gp_io);
1098 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1099 if (PL_op->op_flags & OPf_SPECIAL) {
1107 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1120 if (GIMME == G_ARRAY) {
1126 if (SvGMAGICAL(left))
1128 if (SvGMAGICAL(right))
1131 if (SvNIOKp(left) || !SvPOKp(left) ||
1132 SvNIOKp(right) || !SvPOKp(right) ||
1133 (looks_like_number(left) && *SvPVX(left) != '0' &&
1134 looks_like_number(right) && *SvPVX(right) != '0'))
1136 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1137 DIE(aTHX_ "Range iterator outside integer range");
1148 sv = sv_2mortal(newSViv(i++));
1153 SV *final = sv_mortalcopy(right);
1155 char *tmps = SvPV(final, len);
1157 sv = sv_mortalcopy(left);
1159 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1161 if (strEQ(SvPVX(sv),tmps))
1163 sv = sv_2mortal(newSVsv(sv));
1170 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1172 if ((PL_op->op_private & OPpFLIP_LINENUM)
1173 ? (GvIO(PL_last_in_gv)
1174 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1176 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1177 sv_catpv(targ, "E0");
1188 S_dopoptolabel(pTHX_ char *label)
1191 register PERL_CONTEXT *cx;
1193 for (i = cxstack_ix; i >= 0; i--) {
1195 switch (CxTYPE(cx)) {
1197 if (ckWARN(WARN_EXITING))
1198 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1199 PL_op_name[PL_op->op_type]);
1202 if (ckWARN(WARN_EXITING))
1203 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1204 PL_op_name[PL_op->op_type]);
1207 if (ckWARN(WARN_EXITING))
1208 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1209 PL_op_name[PL_op->op_type]);
1212 if (ckWARN(WARN_EXITING))
1213 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1214 PL_op_name[PL_op->op_type]);
1217 if (ckWARN(WARN_EXITING))
1218 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1219 PL_op_name[PL_op->op_type]);
1222 if (!cx->blk_loop.label ||
1223 strNE(label, cx->blk_loop.label) ) {
1224 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1225 (long)i, cx->blk_loop.label));
1228 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1236 Perl_dowantarray(pTHX)
1238 I32 gimme = block_gimme();
1239 return (gimme == G_VOID) ? G_SCALAR : gimme;
1243 Perl_block_gimme(pTHX)
1247 cxix = dopoptosub(cxstack_ix);
1251 switch (cxstack[cxix].blk_gimme) {
1259 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1266 Perl_is_lvalue_sub(pTHX)
1270 cxix = dopoptosub(cxstack_ix);
1271 assert(cxix >= 0); /* We should only be called from inside subs */
1273 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1274 return cxstack[cxix].blk_sub.lval;
1280 S_dopoptosub(pTHX_ I32 startingblock)
1282 return dopoptosub_at(cxstack, startingblock);
1286 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1289 register PERL_CONTEXT *cx;
1290 for (i = startingblock; i >= 0; i--) {
1292 switch (CxTYPE(cx)) {
1298 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1306 S_dopoptoeval(pTHX_ I32 startingblock)
1309 register PERL_CONTEXT *cx;
1310 for (i = startingblock; i >= 0; i--) {
1312 switch (CxTYPE(cx)) {
1316 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1324 S_dopoptoloop(pTHX_ I32 startingblock)
1327 register PERL_CONTEXT *cx;
1328 for (i = startingblock; i >= 0; i--) {
1330 switch (CxTYPE(cx)) {
1332 if (ckWARN(WARN_EXITING))
1333 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1334 PL_op_name[PL_op->op_type]);
1337 if (ckWARN(WARN_EXITING))
1338 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1339 PL_op_name[PL_op->op_type]);
1342 if (ckWARN(WARN_EXITING))
1343 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1344 PL_op_name[PL_op->op_type]);
1347 if (ckWARN(WARN_EXITING))
1348 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1349 PL_op_name[PL_op->op_type]);
1352 if (ckWARN(WARN_EXITING))
1353 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1354 PL_op_name[PL_op->op_type]);
1357 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1365 Perl_dounwind(pTHX_ I32 cxix)
1367 register PERL_CONTEXT *cx;
1370 while (cxstack_ix > cxix) {
1372 cx = &cxstack[cxstack_ix];
1373 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1374 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1375 /* Note: we don't need to restore the base context info till the end. */
1376 switch (CxTYPE(cx)) {
1379 continue; /* not break */
1401 Perl_qerror(pTHX_ SV *err)
1404 sv_catsv(ERRSV, err);
1406 sv_catsv(PL_errors, err);
1408 Perl_warn(aTHX_ "%"SVf, err);
1413 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1418 register PERL_CONTEXT *cx;
1423 if (PL_in_eval & EVAL_KEEPERR) {
1424 static char prefix[] = "\t(in cleanup) ";
1429 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1432 if (*e != *message || strNE(e,message))
1436 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1437 sv_catpvn(err, prefix, sizeof(prefix)-1);
1438 sv_catpvn(err, message, msglen);
1439 if (ckWARN(WARN_MISC)) {
1440 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1441 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1446 sv_setpvn(ERRSV, message, msglen);
1450 message = SvPVx(ERRSV, msglen);
1452 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1453 && PL_curstackinfo->si_prev)
1462 if (cxix < cxstack_ix)
1465 POPBLOCK(cx,PL_curpm);
1466 if (CxTYPE(cx) != CXt_EVAL) {
1467 PerlIO_write(Perl_error_log, "panic: die ", 11);
1468 PerlIO_write(Perl_error_log, message, msglen);
1473 if (gimme == G_SCALAR)
1474 *++newsp = &PL_sv_undef;
1475 PL_stack_sp = newsp;
1479 /* LEAVE could clobber PL_curcop (see save_re_context())
1480 * XXX it might be better to find a way to avoid messing with
1481 * PL_curcop in save_re_context() instead, but this is a more
1482 * minimal fix --GSAR */
1483 PL_curcop = cx->blk_oldcop;
1485 if (optype == OP_REQUIRE) {
1486 char* msg = SvPVx(ERRSV, n_a);
1487 DIE(aTHX_ "%sCompilation failed in require",
1488 *msg ? msg : "Unknown error\n");
1490 return pop_return();
1494 message = SvPVx(ERRSV, msglen);
1497 /* SFIO can really mess with your errno */
1500 PerlIO *serr = Perl_error_log;
1502 PerlIO_write(serr, message, msglen);
1503 (void)PerlIO_flush(serr);
1516 if (SvTRUE(left) != SvTRUE(right))
1528 RETURNOP(cLOGOP->op_other);
1537 RETURNOP(cLOGOP->op_other);
1543 register I32 cxix = dopoptosub(cxstack_ix);
1544 register PERL_CONTEXT *cx;
1545 register PERL_CONTEXT *ccstack = cxstack;
1546 PERL_SI *top_si = PL_curstackinfo;
1557 /* we may be in a higher stacklevel, so dig down deeper */
1558 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1559 top_si = top_si->si_prev;
1560 ccstack = top_si->si_cxstack;
1561 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1564 if (GIMME != G_ARRAY)
1568 if (PL_DBsub && cxix >= 0 &&
1569 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1573 cxix = dopoptosub_at(ccstack, cxix - 1);
1576 cx = &ccstack[cxix];
1577 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1578 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1579 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1580 field below is defined for any cx. */
1581 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1582 cx = &ccstack[dbcxix];
1585 stashname = CopSTASHPV(cx->blk_oldcop);
1586 if (GIMME != G_ARRAY) {
1588 PUSHs(&PL_sv_undef);
1591 sv_setpv(TARG, stashname);
1598 PUSHs(&PL_sv_undef);
1600 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1601 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1602 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1605 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1606 /* So is ccstack[dbcxix]. */
1608 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1609 PUSHs(sv_2mortal(sv));
1610 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1613 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1614 PUSHs(sv_2mortal(newSViv(0)));
1616 gimme = (I32)cx->blk_gimme;
1617 if (gimme == G_VOID)
1618 PUSHs(&PL_sv_undef);
1620 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1621 if (CxTYPE(cx) == CXt_EVAL) {
1623 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1624 PUSHs(cx->blk_eval.cur_text);
1628 else if (cx->blk_eval.old_namesv) {
1629 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1632 /* eval BLOCK (try blocks have old_namesv == 0) */
1634 PUSHs(&PL_sv_undef);
1635 PUSHs(&PL_sv_undef);
1639 PUSHs(&PL_sv_undef);
1640 PUSHs(&PL_sv_undef);
1642 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1643 && CopSTASH_eq(PL_curcop, PL_debstash))
1645 AV *ary = cx->blk_sub.argarray;
1646 int off = AvARRAY(ary) - AvALLOC(ary);
1650 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1653 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1656 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1657 av_extend(PL_dbargs, AvFILLp(ary) + off);
1658 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1659 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1661 /* XXX only hints propagated via op_private are currently
1662 * visible (others are not easily accessible, since they
1663 * use the global PL_hints) */
1664 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1665 HINT_PRIVATE_MASK)));
1668 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1670 if (old_warnings == pWARN_NONE ||
1671 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1672 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1673 else if (old_warnings == pWARN_ALL ||
1674 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1675 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1677 mask = newSVsv(old_warnings);
1678 PUSHs(sv_2mortal(mask));
1693 sv_reset(tmps, CopSTASH(PL_curcop));
1705 PL_curcop = (COP*)PL_op;
1706 TAINT_NOT; /* Each statement is presumed innocent */
1707 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1710 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1714 register PERL_CONTEXT *cx;
1715 I32 gimme = G_ARRAY;
1722 DIE(aTHX_ "No DB::DB routine defined");
1724 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1725 /* don't do recursive DB::DB call */
1737 push_return(PL_op->op_next);
1738 PUSHBLOCK(cx, CXt_SUB, SP);
1741 (void)SvREFCNT_inc(cv);
1742 SAVEVPTR(PL_curpad);
1743 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1744 RETURNOP(CvSTART(cv));
1758 register PERL_CONTEXT *cx;
1759 I32 gimme = GIMME_V;
1761 U32 cxtype = CXt_LOOP;
1770 if (PL_op->op_flags & OPf_SPECIAL) {
1771 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1772 SAVEGENERICSV(*svp);
1776 #endif /* USE_THREADS */
1777 if (PL_op->op_targ) {
1778 #ifndef USE_ITHREADS
1779 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1782 SAVEPADSV(PL_op->op_targ);
1783 iterdata = (void*)PL_op->op_targ;
1784 cxtype |= CXp_PADVAR;
1789 svp = &GvSV(gv); /* symbol table variable */
1790 SAVEGENERICSV(*svp);
1793 iterdata = (void*)gv;
1799 PUSHBLOCK(cx, cxtype, SP);
1801 PUSHLOOP(cx, iterdata, MARK);
1803 PUSHLOOP(cx, svp, MARK);
1805 if (PL_op->op_flags & OPf_STACKED) {
1806 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1807 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1809 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1810 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1811 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1812 looks_like_number((SV*)cx->blk_loop.iterary) &&
1813 *SvPVX(cx->blk_loop.iterary) != '0'))
1815 if (SvNV(sv) < IV_MIN ||
1816 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1817 DIE(aTHX_ "Range iterator outside integer range");
1818 cx->blk_loop.iterix = SvIV(sv);
1819 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1822 cx->blk_loop.iterlval = newSVsv(sv);
1826 cx->blk_loop.iterary = PL_curstack;
1827 AvFILLp(PL_curstack) = SP - PL_stack_base;
1828 cx->blk_loop.iterix = MARK - PL_stack_base;
1837 register PERL_CONTEXT *cx;
1838 I32 gimme = GIMME_V;
1844 PUSHBLOCK(cx, CXt_LOOP, SP);
1845 PUSHLOOP(cx, 0, SP);
1853 register PERL_CONTEXT *cx;
1861 newsp = PL_stack_base + cx->blk_loop.resetsp;
1864 if (gimme == G_VOID)
1866 else if (gimme == G_SCALAR) {
1868 *++newsp = sv_mortalcopy(*SP);
1870 *++newsp = &PL_sv_undef;
1874 *++newsp = sv_mortalcopy(*++mark);
1875 TAINT_NOT; /* Each item is independent */
1881 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1882 PL_curpm = newpm; /* ... and pop $1 et al */
1894 register PERL_CONTEXT *cx;
1895 bool popsub2 = FALSE;
1896 bool clear_errsv = FALSE;
1903 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1904 if (cxstack_ix == PL_sortcxix
1905 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1907 if (cxstack_ix > PL_sortcxix)
1908 dounwind(PL_sortcxix);
1909 AvARRAY(PL_curstack)[1] = *SP;
1910 PL_stack_sp = PL_stack_base + 1;
1915 cxix = dopoptosub(cxstack_ix);
1917 DIE(aTHX_ "Can't return outside a subroutine");
1918 if (cxix < cxstack_ix)
1922 switch (CxTYPE(cx)) {
1927 if (!(PL_in_eval & EVAL_KEEPERR))
1933 if (optype == OP_REQUIRE &&
1934 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1936 /* Unassume the success we assumed earlier. */
1937 SV *nsv = cx->blk_eval.old_namesv;
1938 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1939 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1946 DIE(aTHX_ "panic: return");
1950 if (gimme == G_SCALAR) {
1953 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1955 *++newsp = SvREFCNT_inc(*SP);
1960 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1962 *++newsp = sv_mortalcopy(sv);
1967 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1970 *++newsp = sv_mortalcopy(*SP);
1973 *++newsp = &PL_sv_undef;
1975 else if (gimme == G_ARRAY) {
1976 while (++MARK <= SP) {
1977 *++newsp = (popsub2 && SvTEMP(*MARK))
1978 ? *MARK : sv_mortalcopy(*MARK);
1979 TAINT_NOT; /* Each item is independent */
1982 PL_stack_sp = newsp;
1984 /* Stack values are safe: */
1986 POPSUB(cx,sv); /* release CV and @_ ... */
1990 PL_curpm = newpm; /* ... and pop $1 et al */
1996 return pop_return();
2003 register PERL_CONTEXT *cx;
2013 if (PL_op->op_flags & OPf_SPECIAL) {
2014 cxix = dopoptoloop(cxstack_ix);
2016 DIE(aTHX_ "Can't \"last\" outside a loop block");
2019 cxix = dopoptolabel(cPVOP->op_pv);
2021 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2023 if (cxix < cxstack_ix)
2028 switch (CxTYPE(cx)) {
2031 newsp = PL_stack_base + cx->blk_loop.resetsp;
2032 nextop = cx->blk_loop.last_op->op_next;
2036 nextop = pop_return();
2040 nextop = pop_return();
2044 nextop = pop_return();
2047 DIE(aTHX_ "panic: last");
2051 if (gimme == G_SCALAR) {
2053 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2054 ? *SP : sv_mortalcopy(*SP);
2056 *++newsp = &PL_sv_undef;
2058 else if (gimme == G_ARRAY) {
2059 while (++MARK <= SP) {
2060 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2061 ? *MARK : sv_mortalcopy(*MARK);
2062 TAINT_NOT; /* Each item is independent */
2068 /* Stack values are safe: */
2071 POPLOOP(cx); /* release loop vars ... */
2075 POPSUB(cx,sv); /* release CV and @_ ... */
2078 PL_curpm = newpm; /* ... and pop $1 et al */
2088 register PERL_CONTEXT *cx;
2091 if (PL_op->op_flags & OPf_SPECIAL) {
2092 cxix = dopoptoloop(cxstack_ix);
2094 DIE(aTHX_ "Can't \"next\" outside a loop block");
2097 cxix = dopoptolabel(cPVOP->op_pv);
2099 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2101 if (cxix < cxstack_ix)
2104 /* clear off anything above the scope we're re-entering, but
2105 * save the rest until after a possible continue block */
2106 inner = PL_scopestack_ix;
2108 if (PL_scopestack_ix < inner)
2109 leave_scope(PL_scopestack[PL_scopestack_ix]);
2110 return cx->blk_loop.next_op;
2116 register PERL_CONTEXT *cx;
2119 if (PL_op->op_flags & OPf_SPECIAL) {
2120 cxix = dopoptoloop(cxstack_ix);
2122 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2125 cxix = dopoptolabel(cPVOP->op_pv);
2127 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2129 if (cxix < cxstack_ix)
2133 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2134 LEAVE_SCOPE(oldsave);
2135 return cx->blk_loop.redo_op;
2139 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2143 static char too_deep[] = "Target of goto is too deeply nested";
2146 Perl_croak(aTHX_ too_deep);
2147 if (o->op_type == OP_LEAVE ||
2148 o->op_type == OP_SCOPE ||
2149 o->op_type == OP_LEAVELOOP ||
2150 o->op_type == OP_LEAVETRY)
2152 *ops++ = cUNOPo->op_first;
2154 Perl_croak(aTHX_ too_deep);
2157 if (o->op_flags & OPf_KIDS) {
2158 /* First try all the kids at this level, since that's likeliest. */
2159 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2160 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2161 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2164 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2165 if (kid == PL_lastgotoprobe)
2167 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2169 (ops[-1]->op_type != OP_NEXTSTATE &&
2170 ops[-1]->op_type != OP_DBSTATE)))
2172 if ((o = dofindlabel(kid, label, ops, oplimit)))
2191 register PERL_CONTEXT *cx;
2192 #define GOTO_DEPTH 64
2193 OP *enterops[GOTO_DEPTH];
2195 int do_dump = (PL_op->op_type == OP_DUMP);
2196 static char must_have_label[] = "goto must have label";
2199 if (PL_op->op_flags & OPf_STACKED) {
2203 /* This egregious kludge implements goto &subroutine */
2204 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2206 register PERL_CONTEXT *cx;
2207 CV* cv = (CV*)SvRV(sv);
2213 if (!CvROOT(cv) && !CvXSUB(cv)) {
2218 /* autoloaded stub? */
2219 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2221 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2222 GvNAMELEN(gv), FALSE);
2223 if (autogv && (cv = GvCV(autogv)))
2225 tmpstr = sv_newmortal();
2226 gv_efullname3(tmpstr, gv, Nullch);
2227 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2229 DIE(aTHX_ "Goto undefined subroutine");
2232 /* First do some returnish stuff. */
2233 cxix = dopoptosub(cxstack_ix);
2235 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2236 if (cxix < cxstack_ix)
2240 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2242 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2243 /* put @_ back onto stack */
2244 AV* av = cx->blk_sub.argarray;
2246 items = AvFILLp(av) + 1;
2248 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2249 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2250 PL_stack_sp += items;
2252 SvREFCNT_dec(GvAV(PL_defgv));
2253 GvAV(PL_defgv) = cx->blk_sub.savearray;
2254 #endif /* USE_THREADS */
2255 /* abandon @_ if it got reified */
2257 (void)sv_2mortal((SV*)av); /* delay until return */
2259 av_extend(av, items-1);
2260 AvFLAGS(av) = AVf_REIFY;
2261 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2264 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2267 av = (AV*)PL_curpad[0];
2269 av = GvAV(PL_defgv);
2271 items = AvFILLp(av) + 1;
2273 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2274 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2275 PL_stack_sp += items;
2277 if (CxTYPE(cx) == CXt_SUB &&
2278 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2279 SvREFCNT_dec(cx->blk_sub.cv);
2280 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2281 LEAVE_SCOPE(oldsave);
2283 /* Now do some callish stuff. */
2286 #ifdef PERL_XSUB_OLDSTYLE
2287 if (CvOLDSTYLE(cv)) {
2288 I32 (*fp3)(int,int,int);
2293 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2294 items = (*fp3)(CvXSUBANY(cv).any_i32,
2295 mark - PL_stack_base + 1,
2297 SP = PL_stack_base + items;
2300 #endif /* PERL_XSUB_OLDSTYLE */
2305 PL_stack_sp--; /* There is no cv arg. */
2306 /* Push a mark for the start of arglist */
2308 (void)(*CvXSUB(cv))(aTHXo_ cv);
2309 /* Pop the current context like a decent sub should */
2310 POPBLOCK(cx, PL_curpm);
2311 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2314 return pop_return();
2317 AV* padlist = CvPADLIST(cv);
2318 SV** svp = AvARRAY(padlist);
2319 if (CxTYPE(cx) == CXt_EVAL) {
2320 PL_in_eval = cx->blk_eval.old_in_eval;
2321 PL_eval_root = cx->blk_eval.old_eval_root;
2322 cx->cx_type = CXt_SUB;
2323 cx->blk_sub.hasargs = 0;
2325 cx->blk_sub.cv = cv;
2326 cx->blk_sub.olddepth = CvDEPTH(cv);
2328 if (CvDEPTH(cv) < 2)
2329 (void)SvREFCNT_inc(cv);
2330 else { /* save temporaries on recursion? */
2331 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2332 sub_crush_depth(cv);
2333 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2334 AV *newpad = newAV();
2335 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2336 I32 ix = AvFILLp((AV*)svp[1]);
2337 I32 names_fill = AvFILLp((AV*)svp[0]);
2338 svp = AvARRAY(svp[0]);
2339 for ( ;ix > 0; ix--) {
2340 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2341 char *name = SvPVX(svp[ix]);
2342 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2345 /* outer lexical or anon code */
2346 av_store(newpad, ix,
2347 SvREFCNT_inc(oldpad[ix]) );
2349 else { /* our own lexical */
2351 av_store(newpad, ix, sv = (SV*)newAV());
2352 else if (*name == '%')
2353 av_store(newpad, ix, sv = (SV*)newHV());
2355 av_store(newpad, ix, sv = NEWSV(0,0));
2359 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2360 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2363 av_store(newpad, ix, sv = NEWSV(0,0));
2367 if (cx->blk_sub.hasargs) {
2370 av_store(newpad, 0, (SV*)av);
2371 AvFLAGS(av) = AVf_REIFY;
2373 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2374 AvFILLp(padlist) = CvDEPTH(cv);
2375 svp = AvARRAY(padlist);
2379 if (!cx->blk_sub.hasargs) {
2380 AV* av = (AV*)PL_curpad[0];
2382 items = AvFILLp(av) + 1;
2384 /* Mark is at the end of the stack. */
2386 Copy(AvARRAY(av), SP + 1, items, SV*);
2391 #endif /* USE_THREADS */
2392 SAVEVPTR(PL_curpad);
2393 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2395 if (cx->blk_sub.hasargs)
2396 #endif /* USE_THREADS */
2398 AV* av = (AV*)PL_curpad[0];
2402 cx->blk_sub.savearray = GvAV(PL_defgv);
2403 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2404 #endif /* USE_THREADS */
2405 cx->blk_sub.oldcurpad = PL_curpad;
2406 cx->blk_sub.argarray = av;
2409 if (items >= AvMAX(av) + 1) {
2411 if (AvARRAY(av) != ary) {
2412 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2413 SvPVX(av) = (char*)ary;
2415 if (items >= AvMAX(av) + 1) {
2416 AvMAX(av) = items - 1;
2417 Renew(ary,items+1,SV*);
2419 SvPVX(av) = (char*)ary;
2422 Copy(mark,AvARRAY(av),items,SV*);
2423 AvFILLp(av) = items - 1;
2424 assert(!AvREAL(av));
2431 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2433 * We do not care about using sv to call CV;
2434 * it's for informational purposes only.
2436 SV *sv = GvSV(PL_DBsub);
2439 if (PERLDB_SUB_NN) {
2440 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2443 gv_efullname3(sv, CvGV(cv), Nullch);
2446 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2447 PUSHMARK( PL_stack_sp );
2448 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2452 RETURNOP(CvSTART(cv));
2456 label = SvPV(sv,n_a);
2457 if (!(do_dump || *label))
2458 DIE(aTHX_ must_have_label);
2461 else if (PL_op->op_flags & OPf_SPECIAL) {
2463 DIE(aTHX_ must_have_label);
2466 label = cPVOP->op_pv;
2468 if (label && *label) {
2470 bool leaving_eval = FALSE;
2471 PERL_CONTEXT *last_eval_cx = 0;
2475 PL_lastgotoprobe = 0;
2477 for (ix = cxstack_ix; ix >= 0; ix--) {
2479 switch (CxTYPE(cx)) {
2481 leaving_eval = TRUE;
2482 if (CxREALEVAL(cx)) {
2483 gotoprobe = (last_eval_cx ?
2484 last_eval_cx->blk_eval.old_eval_root :
2489 /* else fall through */
2491 gotoprobe = cx->blk_oldcop->op_sibling;
2497 gotoprobe = cx->blk_oldcop->op_sibling;
2499 gotoprobe = PL_main_root;
2502 if (CvDEPTH(cx->blk_sub.cv)) {
2503 gotoprobe = CvROOT(cx->blk_sub.cv);
2509 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2512 DIE(aTHX_ "panic: goto");
2513 gotoprobe = PL_main_root;
2517 retop = dofindlabel(gotoprobe, label,
2518 enterops, enterops + GOTO_DEPTH);
2522 PL_lastgotoprobe = gotoprobe;
2525 DIE(aTHX_ "Can't find label %s", label);
2527 /* if we're leaving an eval, check before we pop any frames
2528 that we're not going to punt, otherwise the error
2531 if (leaving_eval && *enterops && enterops[1]) {
2533 for (i = 1; enterops[i]; i++)
2534 if (enterops[i]->op_type == OP_ENTERITER)
2535 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2538 /* pop unwanted frames */
2540 if (ix < cxstack_ix) {
2547 oldsave = PL_scopestack[PL_scopestack_ix];
2548 LEAVE_SCOPE(oldsave);
2551 /* push wanted frames */
2553 if (*enterops && enterops[1]) {
2555 for (ix = 1; enterops[ix]; ix++) {
2556 PL_op = enterops[ix];
2557 /* Eventually we may want to stack the needed arguments
2558 * for each op. For now, we punt on the hard ones. */
2559 if (PL_op->op_type == OP_ENTERITER)
2560 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2561 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2569 if (!retop) retop = PL_main_start;
2571 PL_restartop = retop;
2572 PL_do_undump = TRUE;
2576 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2577 PL_do_undump = FALSE;
2593 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2597 PL_exit_flags |= PERL_EXIT_EXPECTED;
2599 PUSHs(&PL_sv_undef);
2607 NV value = SvNVx(GvSV(cCOP->cop_gv));
2608 register I32 match = I_32(value);
2611 if (((NV)match) > value)
2612 --match; /* was fractional--truncate other way */
2614 match -= cCOP->uop.scop.scop_offset;
2617 else if (match > cCOP->uop.scop.scop_max)
2618 match = cCOP->uop.scop.scop_max;
2619 PL_op = cCOP->uop.scop.scop_next[match];
2629 PL_op = PL_op->op_next; /* can't assume anything */
2632 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2633 match -= cCOP->uop.scop.scop_offset;
2636 else if (match > cCOP->uop.scop.scop_max)
2637 match = cCOP->uop.scop.scop_max;
2638 PL_op = cCOP->uop.scop.scop_next[match];
2647 S_save_lines(pTHX_ AV *array, SV *sv)
2649 register char *s = SvPVX(sv);
2650 register char *send = SvPVX(sv) + SvCUR(sv);
2652 register I32 line = 1;
2654 while (s && s < send) {
2655 SV *tmpstr = NEWSV(85,0);
2657 sv_upgrade(tmpstr, SVt_PVMG);
2658 t = strchr(s, '\n');
2664 sv_setpvn(tmpstr, s, t - s);
2665 av_store(array, line++, tmpstr);
2670 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2672 S_docatch_body(pTHX_ va_list args)
2674 return docatch_body();
2679 S_docatch_body(pTHX)
2686 S_docatch(pTHX_ OP *o)
2690 volatile PERL_SI *cursi = PL_curstackinfo;
2694 assert(CATCH_GET == TRUE);
2697 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2699 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2705 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2711 if (PL_restartop && cursi == PL_curstackinfo) {
2712 PL_op = PL_restartop;
2729 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2730 /* sv Text to convert to OP tree. */
2731 /* startop op_free() this to undo. */
2732 /* code Short string id of the caller. */
2734 dSP; /* Make POPBLOCK work. */
2737 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2741 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2742 char *tmpbuf = tbuf;
2748 /* switch to eval mode */
2750 if (PL_curcop == &PL_compiling) {
2751 SAVECOPSTASH_FREE(&PL_compiling);
2752 CopSTASH_set(&PL_compiling, PL_curstash);
2754 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2755 SV *sv = sv_newmortal();
2756 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2757 code, (unsigned long)++PL_evalseq,
2758 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2762 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2763 SAVECOPFILE_FREE(&PL_compiling);
2764 CopFILE_set(&PL_compiling, tmpbuf+2);
2765 SAVECOPLINE(&PL_compiling);
2766 CopLINE_set(&PL_compiling, 1);
2767 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2768 deleting the eval's FILEGV from the stash before gv_check() runs
2769 (i.e. before run-time proper). To work around the coredump that
2770 ensues, we always turn GvMULTI_on for any globals that were
2771 introduced within evals. See force_ident(). GSAR 96-10-12 */
2772 safestr = savepv(tmpbuf);
2773 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2775 #ifdef OP_IN_REGISTER
2780 PL_hints &= HINT_UTF8;
2783 PL_op->op_type = OP_ENTEREVAL;
2784 PL_op->op_flags = 0; /* Avoid uninit warning. */
2785 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2786 PUSHEVAL(cx, 0, Nullgv);
2787 rop = doeval(G_SCALAR, startop);
2788 POPBLOCK(cx,PL_curpm);
2791 (*startop)->op_type = OP_NULL;
2792 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2794 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2796 if (PL_curcop == &PL_compiling)
2797 PL_compiling.op_private = PL_hints;
2798 #ifdef OP_IN_REGISTER
2804 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2806 S_doeval(pTHX_ int gimme, OP** startop)
2814 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2815 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2820 /* set up a scratch pad */
2823 SAVEVPTR(PL_curpad);
2824 SAVESPTR(PL_comppad);
2825 SAVESPTR(PL_comppad_name);
2826 SAVEI32(PL_comppad_name_fill);
2827 SAVEI32(PL_min_intro_pending);
2828 SAVEI32(PL_max_intro_pending);
2831 for (i = cxstack_ix - 1; i >= 0; i--) {
2832 PERL_CONTEXT *cx = &cxstack[i];
2833 if (CxTYPE(cx) == CXt_EVAL)
2835 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2836 caller = cx->blk_sub.cv;
2841 SAVESPTR(PL_compcv);
2842 PL_compcv = (CV*)NEWSV(1104,0);
2843 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2844 CvEVAL_on(PL_compcv);
2845 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2846 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2849 CvOWNER(PL_compcv) = 0;
2850 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2851 MUTEX_INIT(CvMUTEXP(PL_compcv));
2852 #endif /* USE_THREADS */
2854 PL_comppad = newAV();
2855 av_push(PL_comppad, Nullsv);
2856 PL_curpad = AvARRAY(PL_comppad);
2857 PL_comppad_name = newAV();
2858 PL_comppad_name_fill = 0;
2859 PL_min_intro_pending = 0;
2862 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2863 PL_curpad[0] = (SV*)newAV();
2864 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2865 #endif /* USE_THREADS */
2867 comppadlist = newAV();
2868 AvREAL_off(comppadlist);
2869 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2870 av_store(comppadlist, 1, (SV*)PL_comppad);
2871 CvPADLIST(PL_compcv) = comppadlist;
2874 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2876 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2879 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2881 /* make sure we compile in the right package */
2883 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2884 SAVESPTR(PL_curstash);
2885 PL_curstash = CopSTASH(PL_curcop);
2887 SAVESPTR(PL_beginav);
2888 PL_beginav = newAV();
2889 SAVEFREESV(PL_beginav);
2890 SAVEI32(PL_error_count);
2892 /* try to compile it */
2894 PL_eval_root = Nullop;
2896 PL_curcop = &PL_compiling;
2897 PL_curcop->cop_arybase = 0;
2898 SvREFCNT_dec(PL_rs);
2899 PL_rs = newSVpvn("\n", 1);
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 SvREFCNT_dec(PL_rs);
2938 PL_rs = SvREFCNT_inc(PL_nrs);
2940 MUTEX_LOCK(&PL_eval_mutex);
2942 COND_SIGNAL(&PL_eval_cond);
2943 MUTEX_UNLOCK(&PL_eval_mutex);
2944 #endif /* USE_THREADS */
2947 SvREFCNT_dec(PL_rs);
2948 PL_rs = SvREFCNT_inc(PL_nrs);
2949 CopLINE_set(&PL_compiling, 0);
2951 *startop = PL_eval_root;
2952 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2953 CvOUTSIDE(PL_compcv) = Nullcv;
2955 SAVEFREEOP(PL_eval_root);
2957 scalarvoid(PL_eval_root);
2958 else if (gimme & G_ARRAY)
2961 scalar(PL_eval_root);
2963 DEBUG_x(dump_eval());
2965 /* Register with debugger: */
2966 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2967 CV *cv = get_cv("DB::postponed", FALSE);
2971 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2973 call_sv((SV*)cv, G_DISCARD);
2977 /* compiled okay, so do it */
2979 CvDEPTH(PL_compcv) = 1;
2980 SP = PL_stack_base + POPMARK; /* pop original mark */
2981 PL_op = saveop; /* The caller may need it. */
2982 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2984 MUTEX_LOCK(&PL_eval_mutex);
2986 COND_SIGNAL(&PL_eval_cond);
2987 MUTEX_UNLOCK(&PL_eval_mutex);
2988 #endif /* USE_THREADS */
2990 RETURNOP(PL_eval_start);
2994 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2996 STRLEN namelen = strlen(name);
2999 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3000 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3001 char *pmc = SvPV_nolen(pmcsv);
3004 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3005 fp = PerlIO_open(name, mode);
3008 if (PerlLIO_stat(name, &pmstat) < 0 ||
3009 pmstat.st_mtime < pmcstat.st_mtime)
3011 fp = PerlIO_open(pmc, mode);
3014 fp = PerlIO_open(name, mode);
3017 SvREFCNT_dec(pmcsv);
3020 fp = PerlIO_open(name, mode);
3028 register PERL_CONTEXT *cx;
3032 char *tryname = Nullch;
3033 SV *namesv = Nullsv;
3035 I32 gimme = GIMME_V;
3036 PerlIO *tryrsfp = 0;
3038 int filter_has_file = 0;
3039 GV *filter_child_proc = 0;
3040 SV *filter_state = 0;
3045 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3046 UV rev = 0, ver = 0, sver = 0;
3048 U8 *s = (U8*)SvPVX(sv);
3049 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3051 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3054 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3057 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3060 if (PERL_REVISION < rev
3061 || (PERL_REVISION == rev
3062 && (PERL_VERSION < ver
3063 || (PERL_VERSION == ver
3064 && PERL_SUBVERSION < sver))))
3066 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3067 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3068 PERL_VERSION, PERL_SUBVERSION);
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".%"UVuf".0?)",
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 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3156 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3157 PTR2UV(SvANY(loader)), name);
3158 tryname = SvPVX(namesv);
3169 if (sv_isobject(loader))
3170 count = call_method("INC", G_ARRAY);
3172 count = call_sv(loader, G_ARRAY);
3182 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3186 if (SvTYPE(arg) == SVt_PVGV) {
3187 IO *io = GvIO((GV *)arg);
3192 tryrsfp = IoIFP(io);
3193 if (IoTYPE(io) == IoTYPE_PIPE) {
3194 /* reading from a child process doesn't
3195 nest -- when returning from reading
3196 the inner module, the outer one is
3197 unreadable (closed?) I've tried to
3198 save the gv to manage the lifespan of
3199 the pipe, but this didn't help. XXX */
3200 filter_child_proc = (GV *)arg;
3201 (void)SvREFCNT_inc(filter_child_proc);
3204 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3205 PerlIO_close(IoOFP(io));
3217 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3219 (void)SvREFCNT_inc(filter_sub);
3222 filter_state = SP[i];
3223 (void)SvREFCNT_inc(filter_state);
3227 tryrsfp = PerlIO_open("/dev/null",
3241 filter_has_file = 0;
3242 if (filter_child_proc) {
3243 SvREFCNT_dec(filter_child_proc);
3244 filter_child_proc = 0;
3247 SvREFCNT_dec(filter_state);
3251 SvREFCNT_dec(filter_sub);
3256 char *dir = SvPVx(dirsv, n_a);
3257 #ifdef MACOS_TRADITIONAL
3259 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3263 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3265 sv_setpv(namesv, unixdir);
3266 sv_catpv(namesv, unixname);
3268 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3271 TAINT_PROPER("require");
3272 tryname = SvPVX(namesv);
3273 #ifdef MACOS_TRADITIONAL
3275 /* Convert slashes in the name part, but not the directory part, to colons */
3277 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3281 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3283 if (tryname[0] == '.' && tryname[1] == '/')
3291 SAVECOPFILE_FREE(&PL_compiling);
3292 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3293 SvREFCNT_dec(namesv);
3295 if (PL_op->op_type == OP_REQUIRE) {
3296 char *msgstr = name;
3297 if (namesv) { /* did we lookup @INC? */
3298 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3299 SV *dirmsgsv = NEWSV(0, 0);
3300 AV *ar = GvAVn(PL_incgv);
3302 sv_catpvn(msg, " in @INC", 8);
3303 if (instr(SvPVX(msg), ".h "))
3304 sv_catpv(msg, " (change .h to .ph maybe?)");
3305 if (instr(SvPVX(msg), ".ph "))
3306 sv_catpv(msg, " (did you run h2ph?)");
3307 sv_catpv(msg, " (@INC contains:");
3308 for (i = 0; i <= AvFILL(ar); i++) {
3309 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3310 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3311 sv_catsv(msg, dirmsgsv);
3313 sv_catpvn(msg, ")", 1);
3314 SvREFCNT_dec(dirmsgsv);
3315 msgstr = SvPV_nolen(msg);
3317 DIE(aTHX_ "Can't locate %s", msgstr);
3323 SETERRNO(0, SS$_NORMAL);
3325 /* Assume success here to prevent recursive requirement. */
3326 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3327 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3331 lex_start(sv_2mortal(newSVpvn("",0)));
3332 SAVEGENERICSV(PL_rsfp_filters);
3333 PL_rsfp_filters = Nullav;
3338 SAVESPTR(PL_compiling.cop_warnings);
3339 if (PL_dowarn & G_WARN_ALL_ON)
3340 PL_compiling.cop_warnings = pWARN_ALL ;
3341 else if (PL_dowarn & G_WARN_ALL_OFF)
3342 PL_compiling.cop_warnings = pWARN_NONE ;
3344 PL_compiling.cop_warnings = pWARN_STD ;
3345 SAVESPTR(PL_compiling.cop_io);
3346 PL_compiling.cop_io = Nullsv;
3348 if (filter_sub || filter_child_proc) {
3349 SV *datasv = filter_add(run_user_filter, Nullsv);
3350 IoLINES(datasv) = filter_has_file;
3351 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3352 IoTOP_GV(datasv) = (GV *)filter_state;
3353 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3356 /* switch to eval mode */
3357 push_return(PL_op->op_next);
3358 PUSHBLOCK(cx, CXt_EVAL, SP);
3359 PUSHEVAL(cx, name, Nullgv);
3361 SAVECOPLINE(&PL_compiling);
3362 CopLINE_set(&PL_compiling, 0);
3366 MUTEX_LOCK(&PL_eval_mutex);
3367 if (PL_eval_owner && PL_eval_owner != thr)
3368 while (PL_eval_owner)
3369 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3370 PL_eval_owner = thr;
3371 MUTEX_UNLOCK(&PL_eval_mutex);
3372 #endif /* USE_THREADS */
3373 return DOCATCH(doeval(gimme, NULL));
3378 return pp_require();
3384 register PERL_CONTEXT *cx;
3386 I32 gimme = GIMME_V, was = PL_sub_generation;
3387 char tbuf[TYPE_DIGITS(long) + 12];
3388 char *tmpbuf = tbuf;
3393 if (!SvPV(sv,len) || !len)
3395 TAINT_PROPER("eval");
3401 /* switch to eval mode */
3403 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3404 SV *sv = sv_newmortal();
3405 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3406 (unsigned long)++PL_evalseq,
3407 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3411 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3412 SAVECOPFILE_FREE(&PL_compiling);
3413 CopFILE_set(&PL_compiling, tmpbuf+2);
3414 SAVECOPLINE(&PL_compiling);
3415 CopLINE_set(&PL_compiling, 1);
3416 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3417 deleting the eval's FILEGV from the stash before gv_check() runs
3418 (i.e. before run-time proper). To work around the coredump that
3419 ensues, we always turn GvMULTI_on for any globals that were
3420 introduced within evals. See force_ident(). GSAR 96-10-12 */
3421 safestr = savepv(tmpbuf);
3422 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3424 PL_hints = PL_op->op_targ;
3425 SAVESPTR(PL_compiling.cop_warnings);
3426 if (specialWARN(PL_curcop->cop_warnings))
3427 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3429 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3430 SAVEFREESV(PL_compiling.cop_warnings);
3432 SAVESPTR(PL_compiling.cop_io);
3433 if (specialCopIO(PL_curcop->cop_io))
3434 PL_compiling.cop_io = PL_curcop->cop_io;
3436 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3437 SAVEFREESV(PL_compiling.cop_io);
3440 push_return(PL_op->op_next);
3441 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3442 PUSHEVAL(cx, 0, Nullgv);
3444 /* prepare to compile string */
3446 if (PERLDB_LINE && PL_curstash != PL_debstash)
3447 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3450 MUTEX_LOCK(&PL_eval_mutex);
3451 if (PL_eval_owner && PL_eval_owner != thr)
3452 while (PL_eval_owner)
3453 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3454 PL_eval_owner = thr;
3455 MUTEX_UNLOCK(&PL_eval_mutex);
3456 #endif /* USE_THREADS */
3457 ret = doeval(gimme, NULL);
3458 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3459 && ret != PL_op->op_next) { /* Successive compilation. */
3460 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3462 return DOCATCH(ret);
3472 register PERL_CONTEXT *cx;
3474 U8 save_flags = PL_op -> op_flags;
3479 retop = pop_return();
3482 if (gimme == G_VOID)
3484 else if (gimme == G_SCALAR) {
3487 if (SvFLAGS(TOPs) & SVs_TEMP)
3490 *MARK = sv_mortalcopy(TOPs);
3494 *MARK = &PL_sv_undef;
3499 /* in case LEAVE wipes old return values */
3500 for (mark = newsp + 1; mark <= SP; mark++) {
3501 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3502 *mark = sv_mortalcopy(*mark);
3503 TAINT_NOT; /* Each item is independent */
3507 PL_curpm = newpm; /* Don't pop $1 et al till now */
3510 assert(CvDEPTH(PL_compcv) == 1);
3512 CvDEPTH(PL_compcv) = 0;
3515 if (optype == OP_REQUIRE &&
3516 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3518 /* Unassume the success we assumed earlier. */
3519 SV *nsv = cx->blk_eval.old_namesv;
3520 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3521 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3522 /* die_where() did LEAVE, or we won't be here */
3526 if (!(save_flags & OPf_SPECIAL))
3536 register PERL_CONTEXT *cx;
3537 I32 gimme = GIMME_V;
3542 push_return(cLOGOP->op_other->op_next);
3543 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3546 PL_in_eval = EVAL_INEVAL;
3549 return DOCATCH(PL_op->op_next);
3559 register PERL_CONTEXT *cx;
3567 if (gimme == G_VOID)
3569 else if (gimme == G_SCALAR) {
3572 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3575 *MARK = sv_mortalcopy(TOPs);
3579 *MARK = &PL_sv_undef;
3584 /* in case LEAVE wipes old return values */
3585 for (mark = newsp + 1; mark <= SP; mark++) {
3586 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3587 *mark = sv_mortalcopy(*mark);
3588 TAINT_NOT; /* Each item is independent */
3592 PL_curpm = newpm; /* Don't pop $1 et al till now */
3600 S_doparseform(pTHX_ SV *sv)
3603 register char *s = SvPV_force(sv, len);
3604 register char *send = s + len;
3605 register char *base = Nullch;
3606 register I32 skipspaces = 0;
3607 bool noblank = FALSE;
3608 bool repeat = FALSE;
3609 bool postspace = FALSE;
3617 Perl_croak(aTHX_ "Null picture in formline");
3619 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3624 *fpc++ = FF_LINEMARK;
3625 noblank = repeat = FALSE;
3643 case ' ': case '\t':
3654 *fpc++ = FF_LITERAL;
3662 *fpc++ = skipspaces;
3666 *fpc++ = FF_NEWLINE;
3670 arg = fpc - linepc + 1;
3677 *fpc++ = FF_LINEMARK;
3678 noblank = repeat = FALSE;
3687 ischop = s[-1] == '^';
3693 arg = (s - base) - 1;
3695 *fpc++ = FF_LITERAL;
3704 *fpc++ = FF_LINEGLOB;
3706 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3707 arg = ischop ? 512 : 0;
3717 arg |= 256 + (s - f);
3719 *fpc++ = s - base; /* fieldsize for FETCH */
3720 *fpc++ = FF_DECIMAL;
3723 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3724 arg = ischop ? 512 : 0;
3726 s++; /* skip the '0' first */
3735 arg |= 256 + (s - f);
3737 *fpc++ = s - base; /* fieldsize for FETCH */
3738 *fpc++ = FF_0DECIMAL;
3743 bool ismore = FALSE;
3746 while (*++s == '>') ;
3747 prespace = FF_SPACE;
3749 else if (*s == '|') {
3750 while (*++s == '|') ;
3751 prespace = FF_HALFSPACE;
3756 while (*++s == '<') ;
3759 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3763 *fpc++ = s - base; /* fieldsize for FETCH */
3765 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3783 { /* need to jump to the next word */
3785 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3786 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3787 s = SvPVX(sv) + SvCUR(sv) + z;
3789 Copy(fops, s, arg, U16);
3791 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3796 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3798 * The original code was written in conjunction with BSD Computer Software
3799 * Research Group at University of California, Berkeley.
3801 * See also: "Optimistic Merge Sort" (SODA '92)
3803 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3805 * The code can be distributed under the same terms as Perl itself.
3810 #include <sys/types.h>
3815 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3816 #define Safefree(VAR) free(VAR)
3817 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3818 #endif /* TESTHARNESS */
3820 typedef char * aptr; /* pointer for arithmetic on sizes */
3821 typedef SV * gptr; /* pointers in our lists */
3823 /* Binary merge internal sort, with a few special mods
3824 ** for the special perl environment it now finds itself in.
3826 ** Things that were once options have been hotwired
3827 ** to values suitable for this use. In particular, we'll always
3828 ** initialize looking for natural runs, we'll always produce stable
3829 ** output, and we'll always do Peter McIlroy's binary merge.
3832 /* Pointer types for arithmetic and storage and convenience casts */
3834 #define APTR(P) ((aptr)(P))
3835 #define GPTP(P) ((gptr *)(P))
3836 #define GPPP(P) ((gptr **)(P))
3839 /* byte offset from pointer P to (larger) pointer Q */
3840 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3842 #define PSIZE sizeof(gptr)
3844 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3847 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3848 #define PNBYTE(N) ((N) << (PSHIFT))
3849 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3851 /* Leave optimization to compiler */
3852 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3853 #define PNBYTE(N) ((N) * (PSIZE))
3854 #define PINDEX(P, N) (GPTP(P) + (N))
3857 /* Pointer into other corresponding to pointer into this */
3858 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3860 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3863 /* Runs are identified by a pointer in the auxilliary list.
3864 ** The pointer is at the start of the list,
3865 ** and it points to the start of the next list.
3866 ** NEXT is used as an lvalue, too.
3869 #define NEXT(P) (*GPPP(P))
3872 /* PTHRESH is the minimum number of pairs with the same sense to justify
3873 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3874 ** not just elements, so PTHRESH == 8 means a run of 16.
3879 /* RTHRESH is the number of elements in a run that must compare low
3880 ** to the low element from the opposing run before we justify
3881 ** doing a binary rampup instead of single stepping.
3882 ** In random input, N in a row low should only happen with
3883 ** probability 2^(1-N), so we can risk that we are dealing
3884 ** with orderly input without paying much when we aren't.
3891 ** Overview of algorithm and variables.
3892 ** The array of elements at list1 will be organized into runs of length 2,
3893 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3894 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3896 ** Unless otherwise specified, pair pointers address the first of two elements.
3898 ** b and b+1 are a pair that compare with sense ``sense''.
3899 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3901 ** p2 parallels b in the list2 array, where runs are defined by
3904 ** t represents the ``top'' of the adjacent pairs that might extend
3905 ** the run beginning at b. Usually, t addresses a pair
3906 ** that compares with opposite sense from (b,b+1).
3907 ** However, it may also address a singleton element at the end of list1,
3908 ** or it may be equal to ``last'', the first element beyond list1.
3910 ** r addresses the Nth pair following b. If this would be beyond t,
3911 ** we back it off to t. Only when r is less than t do we consider the
3912 ** run long enough to consider checking.
3914 ** q addresses a pair such that the pairs at b through q already form a run.
3915 ** Often, q will equal b, indicating we only are sure of the pair itself.
3916 ** However, a search on the previous cycle may have revealed a longer run,
3917 ** so q may be greater than b.
3919 ** p is used to work back from a candidate r, trying to reach q,
3920 ** which would mean b through r would be a run. If we discover such a run,
3921 ** we start q at r and try to push it further towards t.
3922 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3923 ** In any event, after the check (if any), we have two main cases.
3925 ** 1) Short run. b <= q < p <= r <= t.
3926 ** b through q is a run (perhaps trivial)
3927 ** q through p are uninteresting pairs
3928 ** p through r is a run
3930 ** 2) Long run. b < r <= q < t.
3931 ** b through q is a run (of length >= 2 * PTHRESH)
3933 ** Note that degenerate cases are not only possible, but likely.
3934 ** For example, if the pair following b compares with opposite sense,
3935 ** then b == q < p == r == t.
3940 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3943 register gptr *b, *p, *q, *t, *p2;
3944 register gptr c, *last, *r;
3948 last = PINDEX(b, nmemb);
3949 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3950 for (p2 = list2; b < last; ) {
3951 /* We just started, or just reversed sense.
3952 ** Set t at end of pairs with the prevailing sense.
3954 for (p = b+2, t = p; ++p < last; t = ++p) {
3955 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3958 /* Having laid out the playing field, look for long runs */
3960 p = r = b + (2 * PTHRESH);
3961 if (r >= t) p = r = t; /* too short to care about */
3963 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3966 /* b through r is a (long) run.
3967 ** Extend it as far as possible.
3970 while (((p += 2) < t) &&
3971 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3972 r = p = q + 2; /* no simple pairs, no after-run */
3975 if (q > b) { /* run of greater than 2 at b */
3978 /* pick up singleton, if possible */
3980 ((t + 1) == last) &&
3981 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3982 savep = r = p = q = last;
3983 p2 = NEXT(p2) = p2 + (p - b);
3984 if (sense) while (b < --p) {
3991 while (q < p) { /* simple pairs */
3992 p2 = NEXT(p2) = p2 + 2;
3999 if (((b = p) == t) && ((t+1) == last)) {
4011 /* Overview of bmerge variables:
4013 ** list1 and list2 address the main and auxiliary arrays.
4014 ** They swap identities after each merge pass.
4015 ** Base points to the original list1, so we can tell if
4016 ** the pointers ended up where they belonged (or must be copied).
4018 ** When we are merging two lists, f1 and f2 are the next elements
4019 ** on the respective lists. l1 and l2 mark the end of the lists.
4020 ** tp2 is the current location in the merged list.
4022 ** p1 records where f1 started.
4023 ** After the merge, a new descriptor is built there.
4025 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4026 ** It is used to identify and delimit the runs.
4028 ** In the heat of determining where q, the greater of the f1/f2 elements,
4029 ** belongs in the other list, b, t and p, represent bottom, top and probe
4030 ** locations, respectively, in the other list.
4031 ** They make convenient temporary pointers in other places.
4035 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4039 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4040 gptr *aux, *list2, *p2, *last;
4044 if (nmemb <= 1) return; /* sorted trivially */
4045 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4047 dynprep(aTHX_ list1, list2, nmemb, cmp);
4048 last = PINDEX(list2, nmemb);
4049 while (NEXT(list2) != last) {
4050 /* More than one run remains. Do some merging to reduce runs. */
4052 for (tp2 = p2 = list2; p2 != last;) {
4053 /* The new first run begins where the old second list ended.
4054 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4058 f2 = l1 = POTHER(t, list2, list1);
4059 if (t != last) t = NEXT(t);
4060 l2 = POTHER(t, list2, list1);
4062 while (f1 < l1 && f2 < l2) {
4063 /* If head 1 is larger than head 2, find ALL the elements
4064 ** in list 2 strictly less than head1, write them all,
4065 ** then head 1. Then compare the new heads, and repeat,
4066 ** until one or both lists are exhausted.
4068 ** In all comparisons (after establishing
4069 ** which head to merge) the item to merge
4070 ** (at pointer q) is the first operand of
4071 ** the comparison. When we want to know
4072 ** if ``q is strictly less than the other'',
4074 ** cmp(q, other) < 0
4075 ** because stability demands that we treat equality
4076 ** as high when q comes from l2, and as low when
4077 ** q was from l1. So we ask the question by doing
4078 ** cmp(q, other) <= sense
4079 ** and make sense == 0 when equality should look low,
4080 ** and -1 when equality should look high.
4084 if (cmp(aTHX_ *f1, *f2) <= 0) {
4085 q = f2; b = f1; t = l1;
4088 q = f1; b = f2; t = l2;
4095 ** Leave t at something strictly
4096 ** greater than q (or at the end of the list),
4097 ** and b at something strictly less than q.
4099 for (i = 1, run = 0 ;;) {
4100 if ((p = PINDEX(b, i)) >= t) {
4102 if (((p = PINDEX(t, -1)) > b) &&
4103 (cmp(aTHX_ *q, *p) <= sense))
4107 } else if (cmp(aTHX_ *q, *p) <= sense) {
4111 if (++run >= RTHRESH) i += i;
4115 /* q is known to follow b and must be inserted before t.
4116 ** Increment b, so the range of possibilities is [b,t).
4117 ** Round binary split down, to favor early appearance.
4118 ** Adjust b and t until q belongs just before t.
4123 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4124 if (cmp(aTHX_ *q, *p) <= sense) {
4130 /* Copy all the strictly low elements */
4133 FROMTOUPTO(f2, tp2, t);
4136 FROMTOUPTO(f1, tp2, t);
4142 /* Run out remaining list */
4144 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4145 } else FROMTOUPTO(f1, tp2, l1);
4146 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4151 last = PINDEX(list2, nmemb);
4153 if (base == list2) {
4154 last = PINDEX(list1, nmemb);
4155 FROMTOUPTO(list1, list2, last);
4170 sortcv(pTHXo_ SV *a, SV *b)
4172 I32 oldsaveix = PL_savestack_ix;
4173 I32 oldscopeix = PL_scopestack_ix;
4175 GvSV(PL_firstgv) = a;
4176 GvSV(PL_secondgv) = b;
4177 PL_stack_sp = PL_stack_base;
4180 if (PL_stack_sp != PL_stack_base + 1)
4181 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4182 if (!SvNIOKp(*PL_stack_sp))
4183 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4184 result = SvIV(*PL_stack_sp);
4185 while (PL_scopestack_ix > oldscopeix) {
4188 leave_scope(oldsaveix);
4193 sortcv_stacked(pTHXo_ SV *a, SV *b)
4195 I32 oldsaveix = PL_savestack_ix;
4196 I32 oldscopeix = PL_scopestack_ix;
4201 av = (AV*)PL_curpad[0];
4203 av = GvAV(PL_defgv);
4206 if (AvMAX(av) < 1) {
4207 SV** ary = AvALLOC(av);
4208 if (AvARRAY(av) != ary) {
4209 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4210 SvPVX(av) = (char*)ary;
4212 if (AvMAX(av) < 1) {
4215 SvPVX(av) = (char*)ary;
4222 PL_stack_sp = PL_stack_base;
4225 if (PL_stack_sp != PL_stack_base + 1)
4226 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4227 if (!SvNIOKp(*PL_stack_sp))
4228 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4229 result = SvIV(*PL_stack_sp);
4230 while (PL_scopestack_ix > oldscopeix) {
4233 leave_scope(oldsaveix);
4238 sortcv_xsub(pTHXo_ SV *a, SV *b)
4241 I32 oldsaveix = PL_savestack_ix;
4242 I32 oldscopeix = PL_scopestack_ix;
4244 CV *cv=(CV*)PL_sortcop;
4252 (void)(*CvXSUB(cv))(aTHXo_ cv);
4253 if (PL_stack_sp != PL_stack_base + 1)
4254 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4255 if (!SvNIOKp(*PL_stack_sp))
4256 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4257 result = SvIV(*PL_stack_sp);
4258 while (PL_scopestack_ix > oldscopeix) {
4261 leave_scope(oldsaveix);
4267 sv_ncmp(pTHXo_ SV *a, SV *b)
4271 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4275 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4279 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4281 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4283 if (PL_amagic_generation) { \
4284 if (SvAMAGIC(left)||SvAMAGIC(right))\
4285 *svp = amagic_call(left, \
4293 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4296 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4301 I32 i = SvIVX(tmpsv);
4311 return sv_ncmp(aTHXo_ a, b);
4315 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4318 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4323 I32 i = SvIVX(tmpsv);
4333 return sv_i_ncmp(aTHXo_ a, b);
4337 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4340 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4345 I32 i = SvIVX(tmpsv);
4355 return sv_cmp(str1, str2);
4359 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4362 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4367 I32 i = SvIVX(tmpsv);
4377 return sv_cmp_locale(str1, str2);
4381 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4383 SV *datasv = FILTER_DATA(idx);
4384 int filter_has_file = IoLINES(datasv);
4385 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4386 SV *filter_state = (SV *)IoTOP_GV(datasv);
4387 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4390 /* I was having segfault trouble under Linux 2.2.5 after a
4391 parse error occured. (Had to hack around it with a test
4392 for PL_error_count == 0.) Solaris doesn't segfault --
4393 not sure where the trouble is yet. XXX */
4395 if (filter_has_file) {
4396 len = FILTER_READ(idx+1, buf_sv, maxlen);
4399 if (filter_sub && len >= 0) {
4410 PUSHs(sv_2mortal(newSViv(maxlen)));
4412 PUSHs(filter_state);
4415 count = call_sv(filter_sub, G_SCALAR);
4431 IoLINES(datasv) = 0;
4432 if (filter_child_proc) {
4433 SvREFCNT_dec(filter_child_proc);
4434 IoFMT_GV(datasv) = Nullgv;
4437 SvREFCNT_dec(filter_state);
4438 IoTOP_GV(datasv) = Nullgv;
4441 SvREFCNT_dec(filter_sub);
4442 IoBOTTOM_GV(datasv) = Nullgv;
4444 filter_del(run_user_filter);
4453 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4455 return sv_cmp_locale(str1, str2);
4459 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4461 return sv_cmp(str1, str2);
4464 #endif /* PERL_OBJECT */