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)
150 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
151 pm->op_pmflags |= PMf_WHITE;
153 pm->op_pmflags &= ~PMf_WHITE;
155 /* XXX runtime compiled output needs to move to the pad */
156 if (pm->op_pmflags & PMf_KEEP) {
157 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
158 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
159 /* XXX can't change the optree at runtime either */
160 cLOGOP->op_first->op_next = PL_op->op_next;
169 register PMOP *pm = (PMOP*) cLOGOP->op_other;
170 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
171 register SV *dstr = cx->sb_dstr;
172 register char *s = cx->sb_s;
173 register char *m = cx->sb_m;
174 char *orig = cx->sb_orig;
175 register REGEXP *rx = cx->sb_rx;
177 rxres_restore(&cx->sb_rxres, rx);
179 if (cx->sb_iters++) {
180 if (cx->sb_iters > cx->sb_maxiters)
181 DIE(aTHX_ "Substitution loop");
183 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
184 cx->sb_rxtainted |= 2;
185 sv_catsv(dstr, POPs);
188 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
189 s == m, cx->sb_targ, NULL,
190 ((cx->sb_rflags & REXEC_COPY_STR)
191 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
192 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
194 SV *targ = cx->sb_targ;
196 sv_catpvn(dstr, s, cx->sb_strend - s);
197 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
199 (void)SvOOK_off(targ);
200 Safefree(SvPVX(targ));
201 SvPVX(targ) = SvPVX(dstr);
202 SvCUR_set(targ, SvCUR(dstr));
203 SvLEN_set(targ, SvLEN(dstr));
209 TAINT_IF(cx->sb_rxtainted & 1);
210 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
212 (void)SvPOK_only_UTF8(targ);
213 TAINT_IF(cx->sb_rxtainted);
217 LEAVE_SCOPE(cx->sb_oldsave);
219 RETURNOP(pm->op_next);
222 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
225 cx->sb_orig = orig = rx->subbeg;
227 cx->sb_strend = s + (cx->sb_strend - m);
229 cx->sb_m = m = rx->startp[0] + orig;
231 sv_catpvn(dstr, s, m-s);
232 cx->sb_s = rx->endp[0] + orig;
233 { /* Update the pos() information. */
234 SV *sv = cx->sb_targ;
237 if (SvTYPE(sv) < SVt_PVMG)
238 (void)SvUPGRADE(sv, SVt_PVMG);
239 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
240 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
241 mg = mg_find(sv, PERL_MAGIC_regex_global);
248 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
249 rxres_save(&cx->sb_rxres, rx);
250 RETURNOP(pm->op_pmreplstart);
254 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
259 if (!p || p[1] < rx->nparens) {
260 i = 6 + rx->nparens * 2;
268 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
269 RX_MATCH_COPIED_off(rx);
273 *p++ = PTR2UV(rx->subbeg);
274 *p++ = (UV)rx->sublen;
275 for (i = 0; i <= rx->nparens; ++i) {
276 *p++ = (UV)rx->startp[i];
277 *p++ = (UV)rx->endp[i];
282 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
287 if (RX_MATCH_COPIED(rx))
288 Safefree(rx->subbeg);
289 RX_MATCH_COPIED_set(rx, *p);
294 rx->subbeg = INT2PTR(char*,*p++);
295 rx->sublen = (I32)(*p++);
296 for (i = 0; i <= rx->nparens; ++i) {
297 rx->startp[i] = (I32)(*p++);
298 rx->endp[i] = (I32)(*p++);
303 Perl_rxres_free(pTHX_ void **rsp)
308 Safefree(INT2PTR(char*,*p));
316 dSP; dMARK; dORIGMARK;
317 register SV *tmpForm = *++MARK;
324 register SV *sv = Nullsv;
329 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
330 char *chophere = Nullch;
331 char *linemark = Nullch;
333 bool gotsome = FALSE;
335 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
336 bool item_is_utf = FALSE;
338 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
339 if (SvREADONLY(tmpForm)) {
340 SvREADONLY_off(tmpForm);
341 doparseform(tmpForm);
342 SvREADONLY_on(tmpForm);
345 doparseform(tmpForm);
348 SvPV_force(PL_formtarget, len);
349 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
351 f = SvPV(tmpForm, len);
352 /* need to jump to the next word */
353 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
362 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
363 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
364 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
365 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
366 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
368 case FF_CHECKNL: name = "CHECKNL"; break;
369 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
370 case FF_SPACE: name = "SPACE"; break;
371 case FF_HALFSPACE: name = "HALFSPACE"; break;
372 case FF_ITEM: name = "ITEM"; break;
373 case FF_CHOP: name = "CHOP"; break;
374 case FF_LINEGLOB: name = "LINEGLOB"; break;
375 case FF_NEWLINE: name = "NEWLINE"; break;
376 case FF_MORE: name = "MORE"; break;
377 case FF_LINEMARK: name = "LINEMARK"; break;
378 case FF_END: name = "END"; break;
379 case FF_0DECIMAL: name = "0DECIMAL"; break;
382 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
384 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
412 if (ckWARN(WARN_SYNTAX))
413 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
418 item = s = SvPV(sv, len);
421 itemsize = sv_len_utf8(sv);
422 if (itemsize != len) {
424 if (itemsize > fieldsize) {
425 itemsize = fieldsize;
426 itembytes = itemsize;
427 sv_pos_u2b(sv, &itembytes, 0);
431 send = chophere = s + itembytes;
441 sv_pos_b2u(sv, &itemsize);
446 if (itemsize > fieldsize)
447 itemsize = fieldsize;
448 send = chophere = s + itemsize;
460 item = s = SvPV(sv, len);
463 itemsize = sv_len_utf8(sv);
464 if (itemsize != len) {
466 if (itemsize <= fieldsize) {
467 send = chophere = s + itemsize;
478 itemsize = fieldsize;
479 itembytes = itemsize;
480 sv_pos_u2b(sv, &itembytes, 0);
481 send = chophere = s + itembytes;
482 while (s < send || (s == send && isSPACE(*s))) {
492 if (strchr(PL_chopset, *s))
497 itemsize = chophere - item;
498 sv_pos_b2u(sv, &itemsize);
505 if (itemsize <= fieldsize) {
506 send = chophere = s + itemsize;
517 itemsize = fieldsize;
518 send = chophere = s + itemsize;
519 while (s < send || (s == send && isSPACE(*s))) {
529 if (strchr(PL_chopset, *s))
534 itemsize = chophere - item;
539 arg = fieldsize - itemsize;
548 arg = fieldsize - itemsize;
562 if (UTF8_IS_CONTINUED(*s)) {
563 STRLEN skip = UTF8SKIP(s);
580 if ( !((*t++ = *s++) & ~31) )
588 int ch = *t++ = *s++;
591 if ( !((*t++ = *s++) & ~31) )
600 while (*s && isSPACE(*s))
607 item = s = SvPV(sv, len);
609 item_is_utf = FALSE; /* XXX is this correct? */
621 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
622 sv_catpvn(PL_formtarget, item, itemsize);
623 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
624 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
629 /* If the field is marked with ^ and the value is undefined,
632 if ((arg & 512) && !SvOK(sv)) {
640 /* Formats aren't yet marked for locales, so assume "yes". */
642 STORE_NUMERIC_STANDARD_SET_LOCAL();
643 #if defined(USE_LONG_DOUBLE)
645 sprintf(t, "%#*.*" PERL_PRIfldbl,
646 (int) fieldsize, (int) arg & 255, value);
648 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
653 (int) fieldsize, (int) arg & 255, value);
656 (int) fieldsize, value);
659 RESTORE_NUMERIC_STANDARD();
665 /* If the field is marked with ^ and the value is undefined,
668 if ((arg & 512) && !SvOK(sv)) {
676 /* Formats aren't yet marked for locales, so assume "yes". */
678 STORE_NUMERIC_STANDARD_SET_LOCAL();
679 #if defined(USE_LONG_DOUBLE)
681 sprintf(t, "%#0*.*" PERL_PRIfldbl,
682 (int) fieldsize, (int) arg & 255, value);
683 /* is this legal? I don't have long doubles */
685 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
689 sprintf(t, "%#0*.*f",
690 (int) fieldsize, (int) arg & 255, value);
693 (int) fieldsize, value);
696 RESTORE_NUMERIC_STANDARD();
703 while (t-- > linemark && *t == ' ') ;
711 if (arg) { /* repeat until fields exhausted? */
713 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
714 lines += FmLINES(PL_formtarget);
717 if (strnEQ(linemark, linemark - arg, arg))
718 DIE(aTHX_ "Runaway format");
720 FmLINES(PL_formtarget) = lines;
722 RETURNOP(cLISTOP->op_first);
735 while (*s && isSPACE(*s) && s < send)
739 arg = fieldsize - itemsize;
746 if (strnEQ(s," ",3)) {
747 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
758 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
759 FmLINES(PL_formtarget) += lines;
771 if (PL_stack_base + *PL_markstack_ptr == SP) {
773 if (GIMME_V == G_SCALAR)
774 XPUSHs(sv_2mortal(newSViv(0)));
775 RETURNOP(PL_op->op_next->op_next);
777 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
778 pp_pushmark(); /* push dst */
779 pp_pushmark(); /* push src */
780 ENTER; /* enter outer scope */
783 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
785 ENTER; /* enter inner scope */
788 src = PL_stack_base[*PL_markstack_ptr];
793 if (PL_op->op_type == OP_MAPSTART)
794 pp_pushmark(); /* push top */
795 return ((LOGOP*)PL_op->op_next)->op_other;
800 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
806 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
812 /* first, move source pointer to the next item in the source list */
813 ++PL_markstack_ptr[-1];
815 /* if there are new items, push them into the destination list */
817 /* might need to make room back there first */
818 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
819 /* XXX this implementation is very pessimal because the stack
820 * is repeatedly extended for every set of items. Is possible
821 * to do this without any stack extension or copying at all
822 * by maintaining a separate list over which the map iterates
823 * (like foreach does). --gsar */
825 /* everything in the stack after the destination list moves
826 * towards the end the stack by the amount of room needed */
827 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
829 /* items to shift up (accounting for the moved source pointer) */
830 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
832 /* This optimization is by Ben Tilly and it does
833 * things differently from what Sarathy (gsar)
834 * is describing. The downside of this optimization is
835 * that leaves "holes" (uninitialized and hopefully unused areas)
836 * to the Perl stack, but on the other hand this
837 * shouldn't be a problem. If Sarathy's idea gets
838 * implemented, this optimization should become
839 * irrelevant. --jhi */
841 shift = count; /* Avoid shifting too often --Ben Tilly */
846 PL_markstack_ptr[-1] += shift;
847 *PL_markstack_ptr += shift;
851 /* copy the new items down to the destination list */
852 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
854 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
856 LEAVE; /* exit inner scope */
859 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
862 (void)POPMARK; /* pop top */
863 LEAVE; /* exit outer scope */
864 (void)POPMARK; /* pop src */
865 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
866 (void)POPMARK; /* pop dst */
867 SP = PL_stack_base + POPMARK; /* pop original mark */
868 if (gimme == G_SCALAR) {
872 else if (gimme == G_ARRAY)
879 ENTER; /* enter inner scope */
882 /* set $_ to the new source item */
883 src = PL_stack_base[PL_markstack_ptr[-1]];
887 RETURNOP(cLOGOP->op_other);
893 dSP; dMARK; dORIGMARK;
895 SV **myorigmark = ORIGMARK;
901 OP* nextop = PL_op->op_next;
903 bool hasargs = FALSE;
906 if (gimme != G_ARRAY) {
912 SAVEVPTR(PL_sortcop);
913 if (PL_op->op_flags & OPf_STACKED) {
914 if (PL_op->op_flags & OPf_SPECIAL) {
915 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
916 kid = kUNOP->op_first; /* pass rv2gv */
917 kid = kUNOP->op_first; /* pass leave */
918 PL_sortcop = kid->op_next;
919 stash = CopSTASH(PL_curcop);
922 cv = sv_2cv(*++MARK, &stash, &gv, 0);
923 if (cv && SvPOK(cv)) {
925 char *proto = SvPV((SV*)cv, n_a);
926 if (proto && strEQ(proto, "$$")) {
930 if (!(cv && CvROOT(cv))) {
931 if (cv && CvXSUB(cv)) {
935 SV *tmpstr = sv_newmortal();
936 gv_efullname3(tmpstr, gv, Nullch);
937 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
941 DIE(aTHX_ "Undefined subroutine in sort");
946 PL_sortcop = (OP*)cv;
948 PL_sortcop = CvSTART(cv);
949 SAVEVPTR(CvROOT(cv)->op_ppaddr);
950 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
953 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
959 stash = CopSTASH(PL_curcop);
963 while (MARK < SP) { /* This may or may not shift down one here. */
965 if ((*up = *++MARK)) { /* Weed out nulls. */
967 if (!PL_sortcop && !SvPOK(*up)) {
972 (void)sv_2pv(*up, &n_a);
977 max = --up - myorigmark;
982 bool oldcatch = CATCH_GET;
988 PUSHSTACKi(PERLSI_SORT);
989 if (!hasargs && !is_xsub) {
990 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
991 SAVESPTR(PL_firstgv);
992 SAVESPTR(PL_secondgv);
993 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
994 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
995 PL_sortstash = stash;
998 sv_lock((SV *)PL_firstgv);
999 sv_lock((SV *)PL_secondgv);
1001 SAVESPTR(GvSV(PL_firstgv));
1002 SAVESPTR(GvSV(PL_secondgv));
1005 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1006 if (!(PL_op->op_flags & OPf_SPECIAL)) {
1007 cx->cx_type = CXt_SUB;
1008 cx->blk_gimme = G_SCALAR;
1011 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1013 PL_sortcxix = cxstack_ix;
1015 if (hasargs && !is_xsub) {
1016 /* This is mostly copied from pp_entersub */
1017 AV *av = (AV*)PL_curpad[0];
1020 cx->blk_sub.savearray = GvAV(PL_defgv);
1021 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1022 #endif /* USE_THREADS */
1023 cx->blk_sub.oldcurpad = PL_curpad;
1024 cx->blk_sub.argarray = av;
1026 qsortsv((myorigmark+1), max,
1027 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1029 POPBLOCK(cx,PL_curpm);
1030 PL_stack_sp = newsp;
1032 CATCH_SET(oldcatch);
1037 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1038 qsortsv(ORIGMARK+1, max,
1039 (PL_op->op_private & OPpSORT_NUMERIC)
1040 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1041 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1042 : ( overloading ? amagic_ncmp : sv_ncmp))
1043 : ( IN_LOCALE_RUNTIME
1046 : sv_cmp_locale_static)
1047 : ( overloading ? amagic_cmp : sv_cmp_static)));
1048 if (PL_op->op_private & OPpSORT_REVERSE) {
1049 SV **p = ORIGMARK+1;
1050 SV **q = ORIGMARK+max;
1060 PL_stack_sp = ORIGMARK + max;
1068 if (GIMME == G_ARRAY)
1070 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1071 return cLOGOP->op_other;
1080 if (GIMME == G_ARRAY) {
1081 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1085 SV *targ = PAD_SV(PL_op->op_targ);
1088 if (PL_op->op_private & OPpFLIP_LINENUM) {
1090 flip = PL_last_in_gv
1091 && (gp_io = GvIO(PL_last_in_gv))
1092 && SvIV(sv) == (IV)IoLINES(gp_io);
1097 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1098 if (PL_op->op_flags & OPf_SPECIAL) {
1106 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1119 if (GIMME == G_ARRAY) {
1125 if (SvGMAGICAL(left))
1127 if (SvGMAGICAL(right))
1130 if (SvNIOKp(left) || !SvPOKp(left) ||
1131 SvNIOKp(right) || !SvPOKp(right) ||
1132 (looks_like_number(left) && *SvPVX(left) != '0' &&
1133 looks_like_number(right) && *SvPVX(right) != '0'))
1135 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1136 DIE(aTHX_ "Range iterator outside integer range");
1147 sv = sv_2mortal(newSViv(i++));
1152 SV *final = sv_mortalcopy(right);
1154 char *tmps = SvPV(final, len);
1156 sv = sv_mortalcopy(left);
1158 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1160 if (strEQ(SvPVX(sv),tmps))
1162 sv = sv_2mortal(newSVsv(sv));
1169 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1171 if ((PL_op->op_private & OPpFLIP_LINENUM)
1172 ? (GvIO(PL_last_in_gv)
1173 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1175 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1176 sv_catpv(targ, "E0");
1187 S_dopoptolabel(pTHX_ char *label)
1190 register PERL_CONTEXT *cx;
1192 for (i = cxstack_ix; i >= 0; i--) {
1194 switch (CxTYPE(cx)) {
1196 if (ckWARN(WARN_EXITING))
1197 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1198 PL_op_name[PL_op->op_type]);
1201 if (ckWARN(WARN_EXITING))
1202 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1203 PL_op_name[PL_op->op_type]);
1206 if (ckWARN(WARN_EXITING))
1207 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1208 PL_op_name[PL_op->op_type]);
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1213 PL_op_name[PL_op->op_type]);
1216 if (ckWARN(WARN_EXITING))
1217 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1218 PL_op_name[PL_op->op_type]);
1221 if (!cx->blk_loop.label ||
1222 strNE(label, cx->blk_loop.label) ) {
1223 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1224 (long)i, cx->blk_loop.label));
1227 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1235 Perl_dowantarray(pTHX)
1237 I32 gimme = block_gimme();
1238 return (gimme == G_VOID) ? G_SCALAR : gimme;
1242 Perl_block_gimme(pTHX)
1246 cxix = dopoptosub(cxstack_ix);
1250 switch (cxstack[cxix].blk_gimme) {
1258 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1265 Perl_is_lvalue_sub(pTHX)
1269 cxix = dopoptosub(cxstack_ix);
1270 assert(cxix >= 0); /* We should only be called from inside subs */
1272 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1273 return cxstack[cxix].blk_sub.lval;
1279 S_dopoptosub(pTHX_ I32 startingblock)
1281 return dopoptosub_at(cxstack, startingblock);
1285 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1288 register PERL_CONTEXT *cx;
1289 for (i = startingblock; i >= 0; i--) {
1291 switch (CxTYPE(cx)) {
1297 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1305 S_dopoptoeval(pTHX_ I32 startingblock)
1308 register PERL_CONTEXT *cx;
1309 for (i = startingblock; i >= 0; i--) {
1311 switch (CxTYPE(cx)) {
1315 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1323 S_dopoptoloop(pTHX_ I32 startingblock)
1326 register PERL_CONTEXT *cx;
1327 for (i = startingblock; i >= 0; i--) {
1329 switch (CxTYPE(cx)) {
1331 if (ckWARN(WARN_EXITING))
1332 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1333 PL_op_name[PL_op->op_type]);
1336 if (ckWARN(WARN_EXITING))
1337 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1338 PL_op_name[PL_op->op_type]);
1341 if (ckWARN(WARN_EXITING))
1342 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1343 PL_op_name[PL_op->op_type]);
1346 if (ckWARN(WARN_EXITING))
1347 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1348 PL_op_name[PL_op->op_type]);
1351 if (ckWARN(WARN_EXITING))
1352 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1353 PL_op_name[PL_op->op_type]);
1356 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1364 Perl_dounwind(pTHX_ I32 cxix)
1366 register PERL_CONTEXT *cx;
1369 while (cxstack_ix > cxix) {
1371 cx = &cxstack[cxstack_ix];
1372 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1373 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1374 /* Note: we don't need to restore the base context info till the end. */
1375 switch (CxTYPE(cx)) {
1378 continue; /* not break */
1400 Perl_qerror(pTHX_ SV *err)
1403 sv_catsv(ERRSV, err);
1405 sv_catsv(PL_errors, err);
1407 Perl_warn(aTHX_ "%"SVf, err);
1412 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1417 register PERL_CONTEXT *cx;
1422 if (PL_in_eval & EVAL_KEEPERR) {
1423 static char prefix[] = "\t(in cleanup) ";
1428 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1431 if (*e != *message || strNE(e,message))
1435 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1436 sv_catpvn(err, prefix, sizeof(prefix)-1);
1437 sv_catpvn(err, message, msglen);
1438 if (ckWARN(WARN_MISC)) {
1439 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1440 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1445 sv_setpvn(ERRSV, message, msglen);
1449 message = SvPVx(ERRSV, msglen);
1451 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1452 && PL_curstackinfo->si_prev)
1461 if (cxix < cxstack_ix)
1464 POPBLOCK(cx,PL_curpm);
1465 if (CxTYPE(cx) != CXt_EVAL) {
1466 PerlIO_write(Perl_error_log, "panic: die ", 11);
1467 PerlIO_write(Perl_error_log, message, msglen);
1472 if (gimme == G_SCALAR)
1473 *++newsp = &PL_sv_undef;
1474 PL_stack_sp = newsp;
1478 /* LEAVE could clobber PL_curcop (see save_re_context())
1479 * XXX it might be better to find a way to avoid messing with
1480 * PL_curcop in save_re_context() instead, but this is a more
1481 * minimal fix --GSAR */
1482 PL_curcop = cx->blk_oldcop;
1484 if (optype == OP_REQUIRE) {
1485 char* msg = SvPVx(ERRSV, n_a);
1486 DIE(aTHX_ "%sCompilation failed in require",
1487 *msg ? msg : "Unknown error\n");
1489 return pop_return();
1493 message = SvPVx(ERRSV, msglen);
1496 /* SFIO can really mess with your errno */
1499 PerlIO *serr = Perl_error_log;
1501 PerlIO_write(serr, message, msglen);
1502 (void)PerlIO_flush(serr);
1515 if (SvTRUE(left) != SvTRUE(right))
1527 RETURNOP(cLOGOP->op_other);
1536 RETURNOP(cLOGOP->op_other);
1542 register I32 cxix = dopoptosub(cxstack_ix);
1543 register PERL_CONTEXT *cx;
1544 register PERL_CONTEXT *ccstack = cxstack;
1545 PERL_SI *top_si = PL_curstackinfo;
1556 /* we may be in a higher stacklevel, so dig down deeper */
1557 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1558 top_si = top_si->si_prev;
1559 ccstack = top_si->si_cxstack;
1560 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1563 if (GIMME != G_ARRAY)
1567 if (PL_DBsub && cxix >= 0 &&
1568 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1572 cxix = dopoptosub_at(ccstack, cxix - 1);
1575 cx = &ccstack[cxix];
1576 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1577 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1578 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1579 field below is defined for any cx. */
1580 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1581 cx = &ccstack[dbcxix];
1584 stashname = CopSTASHPV(cx->blk_oldcop);
1585 if (GIMME != G_ARRAY) {
1587 PUSHs(&PL_sv_undef);
1590 sv_setpv(TARG, stashname);
1597 PUSHs(&PL_sv_undef);
1599 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1600 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1601 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1604 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1605 /* So is ccstack[dbcxix]. */
1607 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1608 PUSHs(sv_2mortal(sv));
1609 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1612 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1613 PUSHs(sv_2mortal(newSViv(0)));
1615 gimme = (I32)cx->blk_gimme;
1616 if (gimme == G_VOID)
1617 PUSHs(&PL_sv_undef);
1619 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1620 if (CxTYPE(cx) == CXt_EVAL) {
1622 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1623 PUSHs(cx->blk_eval.cur_text);
1627 else if (cx->blk_eval.old_namesv) {
1628 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1631 /* eval BLOCK (try blocks have old_namesv == 0) */
1633 PUSHs(&PL_sv_undef);
1634 PUSHs(&PL_sv_undef);
1638 PUSHs(&PL_sv_undef);
1639 PUSHs(&PL_sv_undef);
1641 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1642 && CopSTASH_eq(PL_curcop, PL_debstash))
1644 AV *ary = cx->blk_sub.argarray;
1645 int off = AvARRAY(ary) - AvALLOC(ary);
1649 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1652 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1655 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1656 av_extend(PL_dbargs, AvFILLp(ary) + off);
1657 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1658 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1660 /* XXX only hints propagated via op_private are currently
1661 * visible (others are not easily accessible, since they
1662 * use the global PL_hints) */
1663 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1664 HINT_PRIVATE_MASK)));
1667 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1669 if (old_warnings == pWARN_NONE ||
1670 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1671 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1672 else if (old_warnings == pWARN_ALL ||
1673 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1674 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1676 mask = newSVsv(old_warnings);
1677 PUSHs(sv_2mortal(mask));
1692 sv_reset(tmps, CopSTASH(PL_curcop));
1704 PL_curcop = (COP*)PL_op;
1705 TAINT_NOT; /* Each statement is presumed innocent */
1706 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1709 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1713 register PERL_CONTEXT *cx;
1714 I32 gimme = G_ARRAY;
1721 DIE(aTHX_ "No DB::DB routine defined");
1723 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1724 /* don't do recursive DB::DB call */
1736 push_return(PL_op->op_next);
1737 PUSHBLOCK(cx, CXt_SUB, SP);
1740 (void)SvREFCNT_inc(cv);
1741 SAVEVPTR(PL_curpad);
1742 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1743 RETURNOP(CvSTART(cv));
1757 register PERL_CONTEXT *cx;
1758 I32 gimme = GIMME_V;
1760 U32 cxtype = CXt_LOOP;
1769 if (PL_op->op_flags & OPf_SPECIAL) {
1770 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1771 SAVEGENERICSV(*svp);
1775 #endif /* USE_THREADS */
1776 if (PL_op->op_targ) {
1777 #ifndef USE_ITHREADS
1778 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1781 SAVEPADSV(PL_op->op_targ);
1782 iterdata = (void*)PL_op->op_targ;
1783 cxtype |= CXp_PADVAR;
1788 svp = &GvSV(gv); /* symbol table variable */
1789 SAVEGENERICSV(*svp);
1792 iterdata = (void*)gv;
1798 PUSHBLOCK(cx, cxtype, SP);
1800 PUSHLOOP(cx, iterdata, MARK);
1802 PUSHLOOP(cx, svp, MARK);
1804 if (PL_op->op_flags & OPf_STACKED) {
1805 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1806 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1808 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1809 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1810 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1811 looks_like_number((SV*)cx->blk_loop.iterary) &&
1812 *SvPVX(cx->blk_loop.iterary) != '0'))
1814 if (SvNV(sv) < IV_MIN ||
1815 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1816 DIE(aTHX_ "Range iterator outside integer range");
1817 cx->blk_loop.iterix = SvIV(sv);
1818 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1821 cx->blk_loop.iterlval = newSVsv(sv);
1825 cx->blk_loop.iterary = PL_curstack;
1826 AvFILLp(PL_curstack) = SP - PL_stack_base;
1827 cx->blk_loop.iterix = MARK - PL_stack_base;
1836 register PERL_CONTEXT *cx;
1837 I32 gimme = GIMME_V;
1843 PUSHBLOCK(cx, CXt_LOOP, SP);
1844 PUSHLOOP(cx, 0, SP);
1852 register PERL_CONTEXT *cx;
1860 newsp = PL_stack_base + cx->blk_loop.resetsp;
1863 if (gimme == G_VOID)
1865 else if (gimme == G_SCALAR) {
1867 *++newsp = sv_mortalcopy(*SP);
1869 *++newsp = &PL_sv_undef;
1873 *++newsp = sv_mortalcopy(*++mark);
1874 TAINT_NOT; /* Each item is independent */
1880 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1881 PL_curpm = newpm; /* ... and pop $1 et al */
1893 register PERL_CONTEXT *cx;
1894 bool popsub2 = FALSE;
1895 bool clear_errsv = FALSE;
1902 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1903 if (cxstack_ix == PL_sortcxix
1904 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1906 if (cxstack_ix > PL_sortcxix)
1907 dounwind(PL_sortcxix);
1908 AvARRAY(PL_curstack)[1] = *SP;
1909 PL_stack_sp = PL_stack_base + 1;
1914 cxix = dopoptosub(cxstack_ix);
1916 DIE(aTHX_ "Can't return outside a subroutine");
1917 if (cxix < cxstack_ix)
1921 switch (CxTYPE(cx)) {
1926 if (!(PL_in_eval & EVAL_KEEPERR))
1932 if (optype == OP_REQUIRE &&
1933 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1935 /* Unassume the success we assumed earlier. */
1936 SV *nsv = cx->blk_eval.old_namesv;
1937 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1938 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1945 DIE(aTHX_ "panic: return");
1949 if (gimme == G_SCALAR) {
1952 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1954 *++newsp = SvREFCNT_inc(*SP);
1959 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1961 *++newsp = sv_mortalcopy(sv);
1966 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1969 *++newsp = sv_mortalcopy(*SP);
1972 *++newsp = &PL_sv_undef;
1974 else if (gimme == G_ARRAY) {
1975 while (++MARK <= SP) {
1976 *++newsp = (popsub2 && SvTEMP(*MARK))
1977 ? *MARK : sv_mortalcopy(*MARK);
1978 TAINT_NOT; /* Each item is independent */
1981 PL_stack_sp = newsp;
1983 /* Stack values are safe: */
1985 POPSUB(cx,sv); /* release CV and @_ ... */
1989 PL_curpm = newpm; /* ... and pop $1 et al */
1995 return pop_return();
2002 register PERL_CONTEXT *cx;
2012 if (PL_op->op_flags & OPf_SPECIAL) {
2013 cxix = dopoptoloop(cxstack_ix);
2015 DIE(aTHX_ "Can't \"last\" outside a loop block");
2018 cxix = dopoptolabel(cPVOP->op_pv);
2020 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2022 if (cxix < cxstack_ix)
2027 switch (CxTYPE(cx)) {
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2031 nextop = cx->blk_loop.last_op->op_next;
2035 nextop = pop_return();
2039 nextop = pop_return();
2043 nextop = pop_return();
2046 DIE(aTHX_ "panic: last");
2050 if (gimme == G_SCALAR) {
2052 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2053 ? *SP : sv_mortalcopy(*SP);
2055 *++newsp = &PL_sv_undef;
2057 else if (gimme == G_ARRAY) {
2058 while (++MARK <= SP) {
2059 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2060 ? *MARK : sv_mortalcopy(*MARK);
2061 TAINT_NOT; /* Each item is independent */
2067 /* Stack values are safe: */
2070 POPLOOP(cx); /* release loop vars ... */
2074 POPSUB(cx,sv); /* release CV and @_ ... */
2077 PL_curpm = newpm; /* ... and pop $1 et al */
2087 register PERL_CONTEXT *cx;
2090 if (PL_op->op_flags & OPf_SPECIAL) {
2091 cxix = dopoptoloop(cxstack_ix);
2093 DIE(aTHX_ "Can't \"next\" outside a loop block");
2096 cxix = dopoptolabel(cPVOP->op_pv);
2098 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2100 if (cxix < cxstack_ix)
2103 /* clear off anything above the scope we're re-entering, but
2104 * save the rest until after a possible continue block */
2105 inner = PL_scopestack_ix;
2107 if (PL_scopestack_ix < inner)
2108 leave_scope(PL_scopestack[PL_scopestack_ix]);
2109 return cx->blk_loop.next_op;
2115 register PERL_CONTEXT *cx;
2118 if (PL_op->op_flags & OPf_SPECIAL) {
2119 cxix = dopoptoloop(cxstack_ix);
2121 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2124 cxix = dopoptolabel(cPVOP->op_pv);
2126 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2128 if (cxix < cxstack_ix)
2132 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2133 LEAVE_SCOPE(oldsave);
2134 return cx->blk_loop.redo_op;
2138 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2142 static char too_deep[] = "Target of goto is too deeply nested";
2145 Perl_croak(aTHX_ too_deep);
2146 if (o->op_type == OP_LEAVE ||
2147 o->op_type == OP_SCOPE ||
2148 o->op_type == OP_LEAVELOOP ||
2149 o->op_type == OP_LEAVETRY)
2151 *ops++ = cUNOPo->op_first;
2153 Perl_croak(aTHX_ too_deep);
2156 if (o->op_flags & OPf_KIDS) {
2157 /* First try all the kids at this level, since that's likeliest. */
2158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2159 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2160 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2163 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2164 if (kid == PL_lastgotoprobe)
2166 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2168 (ops[-1]->op_type != OP_NEXTSTATE &&
2169 ops[-1]->op_type != OP_DBSTATE)))
2171 if ((o = dofindlabel(kid, label, ops, oplimit)))
2190 register PERL_CONTEXT *cx;
2191 #define GOTO_DEPTH 64
2192 OP *enterops[GOTO_DEPTH];
2194 int do_dump = (PL_op->op_type == OP_DUMP);
2195 static char must_have_label[] = "goto must have label";
2198 if (PL_op->op_flags & OPf_STACKED) {
2202 /* This egregious kludge implements goto &subroutine */
2203 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2205 register PERL_CONTEXT *cx;
2206 CV* cv = (CV*)SvRV(sv);
2212 if (!CvROOT(cv) && !CvXSUB(cv)) {
2217 /* autoloaded stub? */
2218 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2220 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2221 GvNAMELEN(gv), FALSE);
2222 if (autogv && (cv = GvCV(autogv)))
2224 tmpstr = sv_newmortal();
2225 gv_efullname3(tmpstr, gv, Nullch);
2226 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2228 DIE(aTHX_ "Goto undefined subroutine");
2231 /* First do some returnish stuff. */
2232 cxix = dopoptosub(cxstack_ix);
2234 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2235 if (cxix < cxstack_ix)
2239 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2241 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2242 /* put @_ back onto stack */
2243 AV* av = cx->blk_sub.argarray;
2245 items = AvFILLp(av) + 1;
2247 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2248 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2249 PL_stack_sp += items;
2251 SvREFCNT_dec(GvAV(PL_defgv));
2252 GvAV(PL_defgv) = cx->blk_sub.savearray;
2253 #endif /* USE_THREADS */
2254 /* abandon @_ if it got reified */
2256 (void)sv_2mortal((SV*)av); /* delay until return */
2258 av_extend(av, items-1);
2259 AvFLAGS(av) = AVf_REIFY;
2260 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2263 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2266 av = (AV*)PL_curpad[0];
2268 av = GvAV(PL_defgv);
2270 items = AvFILLp(av) + 1;
2272 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2273 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2274 PL_stack_sp += items;
2276 if (CxTYPE(cx) == CXt_SUB &&
2277 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2278 SvREFCNT_dec(cx->blk_sub.cv);
2279 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2280 LEAVE_SCOPE(oldsave);
2282 /* Now do some callish stuff. */
2285 #ifdef PERL_XSUB_OLDSTYLE
2286 if (CvOLDSTYLE(cv)) {
2287 I32 (*fp3)(int,int,int);
2292 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2293 items = (*fp3)(CvXSUBANY(cv).any_i32,
2294 mark - PL_stack_base + 1,
2296 SP = PL_stack_base + items;
2299 #endif /* PERL_XSUB_OLDSTYLE */
2304 PL_stack_sp--; /* There is no cv arg. */
2305 /* Push a mark for the start of arglist */
2307 (void)(*CvXSUB(cv))(aTHXo_ cv);
2308 /* Pop the current context like a decent sub should */
2309 POPBLOCK(cx, PL_curpm);
2310 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2313 return pop_return();
2316 AV* padlist = CvPADLIST(cv);
2317 SV** svp = AvARRAY(padlist);
2318 if (CxTYPE(cx) == CXt_EVAL) {
2319 PL_in_eval = cx->blk_eval.old_in_eval;
2320 PL_eval_root = cx->blk_eval.old_eval_root;
2321 cx->cx_type = CXt_SUB;
2322 cx->blk_sub.hasargs = 0;
2324 cx->blk_sub.cv = cv;
2325 cx->blk_sub.olddepth = CvDEPTH(cv);
2327 if (CvDEPTH(cv) < 2)
2328 (void)SvREFCNT_inc(cv);
2329 else { /* save temporaries on recursion? */
2330 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2331 sub_crush_depth(cv);
2332 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2333 AV *newpad = newAV();
2334 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2335 I32 ix = AvFILLp((AV*)svp[1]);
2336 I32 names_fill = AvFILLp((AV*)svp[0]);
2337 svp = AvARRAY(svp[0]);
2338 for ( ;ix > 0; ix--) {
2339 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2340 char *name = SvPVX(svp[ix]);
2341 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2344 /* outer lexical or anon code */
2345 av_store(newpad, ix,
2346 SvREFCNT_inc(oldpad[ix]) );
2348 else { /* our own lexical */
2350 av_store(newpad, ix, sv = (SV*)newAV());
2351 else if (*name == '%')
2352 av_store(newpad, ix, sv = (SV*)newHV());
2354 av_store(newpad, ix, sv = NEWSV(0,0));
2358 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2359 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2362 av_store(newpad, ix, sv = NEWSV(0,0));
2366 if (cx->blk_sub.hasargs) {
2369 av_store(newpad, 0, (SV*)av);
2370 AvFLAGS(av) = AVf_REIFY;
2372 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2373 AvFILLp(padlist) = CvDEPTH(cv);
2374 svp = AvARRAY(padlist);
2378 if (!cx->blk_sub.hasargs) {
2379 AV* av = (AV*)PL_curpad[0];
2381 items = AvFILLp(av) + 1;
2383 /* Mark is at the end of the stack. */
2385 Copy(AvARRAY(av), SP + 1, items, SV*);
2390 #endif /* USE_THREADS */
2391 SAVEVPTR(PL_curpad);
2392 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2394 if (cx->blk_sub.hasargs)
2395 #endif /* USE_THREADS */
2397 AV* av = (AV*)PL_curpad[0];
2401 cx->blk_sub.savearray = GvAV(PL_defgv);
2402 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2403 #endif /* USE_THREADS */
2404 cx->blk_sub.oldcurpad = PL_curpad;
2405 cx->blk_sub.argarray = av;
2408 if (items >= AvMAX(av) + 1) {
2410 if (AvARRAY(av) != ary) {
2411 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2412 SvPVX(av) = (char*)ary;
2414 if (items >= AvMAX(av) + 1) {
2415 AvMAX(av) = items - 1;
2416 Renew(ary,items+1,SV*);
2418 SvPVX(av) = (char*)ary;
2421 Copy(mark,AvARRAY(av),items,SV*);
2422 AvFILLp(av) = items - 1;
2423 assert(!AvREAL(av));
2430 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2432 * We do not care about using sv to call CV;
2433 * it's for informational purposes only.
2435 SV *sv = GvSV(PL_DBsub);
2438 if (PERLDB_SUB_NN) {
2439 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2442 gv_efullname3(sv, CvGV(cv), Nullch);
2445 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2446 PUSHMARK( PL_stack_sp );
2447 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2451 RETURNOP(CvSTART(cv));
2455 label = SvPV(sv,n_a);
2456 if (!(do_dump || *label))
2457 DIE(aTHX_ must_have_label);
2460 else if (PL_op->op_flags & OPf_SPECIAL) {
2462 DIE(aTHX_ must_have_label);
2465 label = cPVOP->op_pv;
2467 if (label && *label) {
2469 bool leaving_eval = FALSE;
2470 PERL_CONTEXT *last_eval_cx = 0;
2474 PL_lastgotoprobe = 0;
2476 for (ix = cxstack_ix; ix >= 0; ix--) {
2478 switch (CxTYPE(cx)) {
2480 leaving_eval = TRUE;
2481 if (CxREALEVAL(cx)) {
2482 gotoprobe = (last_eval_cx ?
2483 last_eval_cx->blk_eval.old_eval_root :
2488 /* else fall through */
2490 gotoprobe = cx->blk_oldcop->op_sibling;
2496 gotoprobe = cx->blk_oldcop->op_sibling;
2498 gotoprobe = PL_main_root;
2501 if (CvDEPTH(cx->blk_sub.cv)) {
2502 gotoprobe = CvROOT(cx->blk_sub.cv);
2508 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2511 DIE(aTHX_ "panic: goto");
2512 gotoprobe = PL_main_root;
2516 retop = dofindlabel(gotoprobe, label,
2517 enterops, enterops + GOTO_DEPTH);
2521 PL_lastgotoprobe = gotoprobe;
2524 DIE(aTHX_ "Can't find label %s", label);
2526 /* if we're leaving an eval, check before we pop any frames
2527 that we're not going to punt, otherwise the error
2530 if (leaving_eval && *enterops && enterops[1]) {
2532 for (i = 1; enterops[i]; i++)
2533 if (enterops[i]->op_type == OP_ENTERITER)
2534 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2537 /* pop unwanted frames */
2539 if (ix < cxstack_ix) {
2546 oldsave = PL_scopestack[PL_scopestack_ix];
2547 LEAVE_SCOPE(oldsave);
2550 /* push wanted frames */
2552 if (*enterops && enterops[1]) {
2554 for (ix = 1; enterops[ix]; ix++) {
2555 PL_op = enterops[ix];
2556 /* Eventually we may want to stack the needed arguments
2557 * for each op. For now, we punt on the hard ones. */
2558 if (PL_op->op_type == OP_ENTERITER)
2559 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2560 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2568 if (!retop) retop = PL_main_start;
2570 PL_restartop = retop;
2571 PL_do_undump = TRUE;
2575 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2576 PL_do_undump = FALSE;
2592 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2596 PL_exit_flags |= PERL_EXIT_EXPECTED;
2598 PUSHs(&PL_sv_undef);
2606 NV value = SvNVx(GvSV(cCOP->cop_gv));
2607 register I32 match = I_32(value);
2610 if (((NV)match) > value)
2611 --match; /* was fractional--truncate other way */
2613 match -= cCOP->uop.scop.scop_offset;
2616 else if (match > cCOP->uop.scop.scop_max)
2617 match = cCOP->uop.scop.scop_max;
2618 PL_op = cCOP->uop.scop.scop_next[match];
2628 PL_op = PL_op->op_next; /* can't assume anything */
2631 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2632 match -= cCOP->uop.scop.scop_offset;
2635 else if (match > cCOP->uop.scop.scop_max)
2636 match = cCOP->uop.scop.scop_max;
2637 PL_op = cCOP->uop.scop.scop_next[match];
2646 S_save_lines(pTHX_ AV *array, SV *sv)
2648 register char *s = SvPVX(sv);
2649 register char *send = SvPVX(sv) + SvCUR(sv);
2651 register I32 line = 1;
2653 while (s && s < send) {
2654 SV *tmpstr = NEWSV(85,0);
2656 sv_upgrade(tmpstr, SVt_PVMG);
2657 t = strchr(s, '\n');
2663 sv_setpvn(tmpstr, s, t - s);
2664 av_store(array, line++, tmpstr);
2669 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2671 S_docatch_body(pTHX_ va_list args)
2673 return docatch_body();
2678 S_docatch_body(pTHX)
2685 S_docatch(pTHX_ OP *o)
2689 volatile PERL_SI *cursi = PL_curstackinfo;
2693 assert(CATCH_GET == TRUE);
2696 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2698 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2704 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2710 if (PL_restartop && cursi == PL_curstackinfo) {
2711 PL_op = PL_restartop;
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2733 dSP; /* Make POPBLOCK work. */
2736 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2740 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741 char *tmpbuf = tbuf;
2747 /* switch to eval mode */
2749 if (PL_curcop == &PL_compiling) {
2750 SAVECOPSTASH_FREE(&PL_compiling);
2751 CopSTASH_set(&PL_compiling, PL_curstash);
2753 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2754 SV *sv = sv_newmortal();
2755 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2756 code, (unsigned long)++PL_evalseq,
2757 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2761 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2762 SAVECOPFILE_FREE(&PL_compiling);
2763 CopFILE_set(&PL_compiling, tmpbuf+2);
2764 SAVECOPLINE(&PL_compiling);
2765 CopLINE_set(&PL_compiling, 1);
2766 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2767 deleting the eval's FILEGV from the stash before gv_check() runs
2768 (i.e. before run-time proper). To work around the coredump that
2769 ensues, we always turn GvMULTI_on for any globals that were
2770 introduced within evals. See force_ident(). GSAR 96-10-12 */
2771 safestr = savepv(tmpbuf);
2772 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2774 #ifdef OP_IN_REGISTER
2779 PL_hints &= HINT_UTF8;
2782 PL_op->op_type = OP_ENTEREVAL;
2783 PL_op->op_flags = 0; /* Avoid uninit warning. */
2784 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2785 PUSHEVAL(cx, 0, Nullgv);
2786 rop = doeval(G_SCALAR, startop);
2787 POPBLOCK(cx,PL_curpm);
2790 (*startop)->op_type = OP_NULL;
2791 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2793 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2795 if (PL_curcop == &PL_compiling)
2796 PL_compiling.op_private = PL_hints;
2797 #ifdef OP_IN_REGISTER
2803 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2805 S_doeval(pTHX_ int gimme, OP** startop)
2813 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2814 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2819 /* set up a scratch pad */
2822 SAVEVPTR(PL_curpad);
2823 SAVESPTR(PL_comppad);
2824 SAVESPTR(PL_comppad_name);
2825 SAVEI32(PL_comppad_name_fill);
2826 SAVEI32(PL_min_intro_pending);
2827 SAVEI32(PL_max_intro_pending);
2830 for (i = cxstack_ix - 1; i >= 0; i--) {
2831 PERL_CONTEXT *cx = &cxstack[i];
2832 if (CxTYPE(cx) == CXt_EVAL)
2834 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2835 caller = cx->blk_sub.cv;
2840 SAVESPTR(PL_compcv);
2841 PL_compcv = (CV*)NEWSV(1104,0);
2842 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2843 CvEVAL_on(PL_compcv);
2844 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2845 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2848 CvOWNER(PL_compcv) = 0;
2849 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2850 MUTEX_INIT(CvMUTEXP(PL_compcv));
2851 #endif /* USE_THREADS */
2853 PL_comppad = newAV();
2854 av_push(PL_comppad, Nullsv);
2855 PL_curpad = AvARRAY(PL_comppad);
2856 PL_comppad_name = newAV();
2857 PL_comppad_name_fill = 0;
2858 PL_min_intro_pending = 0;
2861 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2862 PL_curpad[0] = (SV*)newAV();
2863 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2864 #endif /* USE_THREADS */
2866 comppadlist = newAV();
2867 AvREAL_off(comppadlist);
2868 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2869 av_store(comppadlist, 1, (SV*)PL_comppad);
2870 CvPADLIST(PL_compcv) = comppadlist;
2873 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2875 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2878 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2880 /* make sure we compile in the right package */
2882 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2883 SAVESPTR(PL_curstash);
2884 PL_curstash = CopSTASH(PL_curcop);
2886 SAVESPTR(PL_beginav);
2887 PL_beginav = newAV();
2888 SAVEFREESV(PL_beginav);
2889 SAVEI32(PL_error_count);
2891 /* try to compile it */
2893 PL_eval_root = Nullop;
2895 PL_curcop = &PL_compiling;
2896 PL_curcop->cop_arybase = 0;
2897 SvREFCNT_dec(PL_rs);
2898 PL_rs = newSVpvn("\n", 1);
2899 if (saveop && saveop->op_flags & OPf_SPECIAL)
2900 PL_in_eval |= EVAL_KEEPERR;
2903 if (yyparse() || PL_error_count || !PL_eval_root) {
2907 I32 optype = 0; /* Might be reset by POPEVAL. */
2912 op_free(PL_eval_root);
2913 PL_eval_root = Nullop;
2915 SP = PL_stack_base + POPMARK; /* pop original mark */
2917 POPBLOCK(cx,PL_curpm);
2923 if (optype == OP_REQUIRE) {
2924 char* msg = SvPVx(ERRSV, n_a);
2925 DIE(aTHX_ "%sCompilation failed in require",
2926 *msg ? msg : "Unknown error\n");
2929 char* msg = SvPVx(ERRSV, n_a);
2931 POPBLOCK(cx,PL_curpm);
2933 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2934 (*msg ? msg : "Unknown error\n"));
2936 SvREFCNT_dec(PL_rs);
2937 PL_rs = SvREFCNT_inc(PL_nrs);
2939 MUTEX_LOCK(&PL_eval_mutex);
2941 COND_SIGNAL(&PL_eval_cond);
2942 MUTEX_UNLOCK(&PL_eval_mutex);
2943 #endif /* USE_THREADS */
2946 SvREFCNT_dec(PL_rs);
2947 PL_rs = SvREFCNT_inc(PL_nrs);
2948 CopLINE_set(&PL_compiling, 0);
2950 *startop = PL_eval_root;
2951 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2952 CvOUTSIDE(PL_compcv) = Nullcv;
2954 SAVEFREEOP(PL_eval_root);
2956 scalarvoid(PL_eval_root);
2957 else if (gimme & G_ARRAY)
2960 scalar(PL_eval_root);
2962 DEBUG_x(dump_eval());
2964 /* Register with debugger: */
2965 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2966 CV *cv = get_cv("DB::postponed", FALSE);
2970 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2972 call_sv((SV*)cv, G_DISCARD);
2976 /* compiled okay, so do it */
2978 CvDEPTH(PL_compcv) = 1;
2979 SP = PL_stack_base + POPMARK; /* pop original mark */
2980 PL_op = saveop; /* The caller may need it. */
2981 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2983 MUTEX_LOCK(&PL_eval_mutex);
2985 COND_SIGNAL(&PL_eval_cond);
2986 MUTEX_UNLOCK(&PL_eval_mutex);
2987 #endif /* USE_THREADS */
2989 RETURNOP(PL_eval_start);
2993 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2995 STRLEN namelen = strlen(name);
2998 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2999 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3000 char *pmc = SvPV_nolen(pmcsv);
3003 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3004 fp = PerlIO_open(name, mode);
3007 if (PerlLIO_stat(name, &pmstat) < 0 ||
3008 pmstat.st_mtime < pmcstat.st_mtime)
3010 fp = PerlIO_open(pmc, mode);
3013 fp = PerlIO_open(name, mode);
3016 SvREFCNT_dec(pmcsv);
3019 fp = PerlIO_open(name, mode);
3027 register PERL_CONTEXT *cx;
3031 char *tryname = Nullch;
3032 SV *namesv = Nullsv;
3034 I32 gimme = GIMME_V;
3035 PerlIO *tryrsfp = 0;
3037 int filter_has_file = 0;
3038 GV *filter_child_proc = 0;
3039 SV *filter_state = 0;
3044 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3045 UV rev = 0, ver = 0, sver = 0;
3047 U8 *s = (U8*)SvPVX(sv);
3048 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3050 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3053 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3056 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3059 if (PERL_REVISION < rev
3060 || (PERL_REVISION == rev
3061 && (PERL_VERSION < ver
3062 || (PERL_VERSION == ver
3063 && PERL_SUBVERSION < sver))))
3065 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3066 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3067 PERL_VERSION, PERL_SUBVERSION);
3071 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3072 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3073 + ((NV)PERL_SUBVERSION/(NV)1000000)
3074 + 0.00000099 < SvNV(sv))
3078 NV nver = (nrev - rev) * 1000;
3079 UV ver = (UV)(nver + 0.0009);
3080 NV nsver = (nver - ver) * 1000;
3081 UV sver = (UV)(nsver + 0.0009);
3083 /* help out with the "use 5.6" confusion */
3084 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3085 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3086 "this is only v%d.%d.%d, stopped"
3087 " (did you mean v%"UVuf".%"UVuf".0?)",
3088 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3089 PERL_SUBVERSION, rev, ver/100);
3092 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3093 "this is only v%d.%d.%d, stopped",
3094 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3101 name = SvPV(sv, len);
3102 if (!(name && len > 0 && *name))
3103 DIE(aTHX_ "Null filename used");
3104 TAINT_PROPER("require");
3105 if (PL_op->op_type == OP_REQUIRE &&
3106 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3107 *svp != &PL_sv_undef)
3110 /* prepare to compile file */
3112 #ifdef MACOS_TRADITIONAL
3113 if (PERL_FILE_IS_ABSOLUTE(name)
3114 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3117 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3118 /* We consider paths of the form :a:b ambiguous and interpret them first
3119 as global then as local
3121 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3127 if (PERL_FILE_IS_ABSOLUTE(name)
3128 || (*name == '.' && (name[1] == '/' ||
3129 (name[1] == '.' && name[2] == '/'))))
3132 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3136 AV *ar = GvAVn(PL_incgv);
3140 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3143 namesv = NEWSV(806, 0);
3144 for (i = 0; i <= AvFILL(ar); i++) {
3145 SV *dirsv = *av_fetch(ar, i, TRUE);
3151 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3152 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3155 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3156 PTR2UV(SvANY(loader)), name);
3157 tryname = SvPVX(namesv);
3168 if (sv_isobject(loader))
3169 count = call_method("INC", G_ARRAY);
3171 count = call_sv(loader, G_ARRAY);
3181 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3185 if (SvTYPE(arg) == SVt_PVGV) {
3186 IO *io = GvIO((GV *)arg);
3191 tryrsfp = IoIFP(io);
3192 if (IoTYPE(io) == IoTYPE_PIPE) {
3193 /* reading from a child process doesn't
3194 nest -- when returning from reading
3195 the inner module, the outer one is
3196 unreadable (closed?) I've tried to
3197 save the gv to manage the lifespan of
3198 the pipe, but this didn't help. XXX */
3199 filter_child_proc = (GV *)arg;
3200 (void)SvREFCNT_inc(filter_child_proc);
3203 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3204 PerlIO_close(IoOFP(io));
3216 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3218 (void)SvREFCNT_inc(filter_sub);
3221 filter_state = SP[i];
3222 (void)SvREFCNT_inc(filter_state);
3226 tryrsfp = PerlIO_open("/dev/null",
3240 filter_has_file = 0;
3241 if (filter_child_proc) {
3242 SvREFCNT_dec(filter_child_proc);
3243 filter_child_proc = 0;
3246 SvREFCNT_dec(filter_state);
3250 SvREFCNT_dec(filter_sub);
3255 char *dir = SvPVx(dirsv, n_a);
3256 #ifdef MACOS_TRADITIONAL
3258 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3262 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3264 sv_setpv(namesv, unixdir);
3265 sv_catpv(namesv, unixname);
3267 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3270 TAINT_PROPER("require");
3271 tryname = SvPVX(namesv);
3272 #ifdef MACOS_TRADITIONAL
3274 /* Convert slashes in the name part, but not the directory part, to colons */
3276 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3280 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3282 if (tryname[0] == '.' && tryname[1] == '/')
3290 SAVECOPFILE_FREE(&PL_compiling);
3291 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3292 SvREFCNT_dec(namesv);
3294 if (PL_op->op_type == OP_REQUIRE) {
3295 char *msgstr = name;
3296 if (namesv) { /* did we lookup @INC? */
3297 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3298 SV *dirmsgsv = NEWSV(0, 0);
3299 AV *ar = GvAVn(PL_incgv);
3301 sv_catpvn(msg, " in @INC", 8);
3302 if (instr(SvPVX(msg), ".h "))
3303 sv_catpv(msg, " (change .h to .ph maybe?)");
3304 if (instr(SvPVX(msg), ".ph "))
3305 sv_catpv(msg, " (did you run h2ph?)");
3306 sv_catpv(msg, " (@INC contains:");
3307 for (i = 0; i <= AvFILL(ar); i++) {
3308 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3309 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3310 sv_catsv(msg, dirmsgsv);
3312 sv_catpvn(msg, ")", 1);
3313 SvREFCNT_dec(dirmsgsv);
3314 msgstr = SvPV_nolen(msg);
3316 DIE(aTHX_ "Can't locate %s", msgstr);
3322 SETERRNO(0, SS$_NORMAL);
3324 /* Assume success here to prevent recursive requirement. */
3325 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3326 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3330 lex_start(sv_2mortal(newSVpvn("",0)));
3331 SAVEGENERICSV(PL_rsfp_filters);
3332 PL_rsfp_filters = Nullav;
3337 SAVESPTR(PL_compiling.cop_warnings);
3338 if (PL_dowarn & G_WARN_ALL_ON)
3339 PL_compiling.cop_warnings = pWARN_ALL ;
3340 else if (PL_dowarn & G_WARN_ALL_OFF)
3341 PL_compiling.cop_warnings = pWARN_NONE ;
3343 PL_compiling.cop_warnings = pWARN_STD ;
3344 SAVESPTR(PL_compiling.cop_io);
3345 PL_compiling.cop_io = Nullsv;
3347 if (filter_sub || filter_child_proc) {
3348 SV *datasv = filter_add(run_user_filter, Nullsv);
3349 IoLINES(datasv) = filter_has_file;
3350 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3351 IoTOP_GV(datasv) = (GV *)filter_state;
3352 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3355 /* switch to eval mode */
3356 push_return(PL_op->op_next);
3357 PUSHBLOCK(cx, CXt_EVAL, SP);
3358 PUSHEVAL(cx, name, Nullgv);
3360 SAVECOPLINE(&PL_compiling);
3361 CopLINE_set(&PL_compiling, 0);
3365 MUTEX_LOCK(&PL_eval_mutex);
3366 if (PL_eval_owner && PL_eval_owner != thr)
3367 while (PL_eval_owner)
3368 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3369 PL_eval_owner = thr;
3370 MUTEX_UNLOCK(&PL_eval_mutex);
3371 #endif /* USE_THREADS */
3372 return DOCATCH(doeval(gimme, NULL));
3377 return pp_require();
3383 register PERL_CONTEXT *cx;
3385 I32 gimme = GIMME_V, was = PL_sub_generation;
3386 char tbuf[TYPE_DIGITS(long) + 12];
3387 char *tmpbuf = tbuf;
3392 if (!SvPV(sv,len) || !len)
3394 TAINT_PROPER("eval");
3400 /* switch to eval mode */
3402 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3403 SV *sv = sv_newmortal();
3404 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3405 (unsigned long)++PL_evalseq,
3406 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3410 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3411 SAVECOPFILE_FREE(&PL_compiling);
3412 CopFILE_set(&PL_compiling, tmpbuf+2);
3413 SAVECOPLINE(&PL_compiling);
3414 CopLINE_set(&PL_compiling, 1);
3415 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3416 deleting the eval's FILEGV from the stash before gv_check() runs
3417 (i.e. before run-time proper). To work around the coredump that
3418 ensues, we always turn GvMULTI_on for any globals that were
3419 introduced within evals. See force_ident(). GSAR 96-10-12 */
3420 safestr = savepv(tmpbuf);
3421 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3423 PL_hints = PL_op->op_targ;
3424 SAVESPTR(PL_compiling.cop_warnings);
3425 if (specialWARN(PL_curcop->cop_warnings))
3426 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3428 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3429 SAVEFREESV(PL_compiling.cop_warnings);
3431 SAVESPTR(PL_compiling.cop_io);
3432 if (specialCopIO(PL_curcop->cop_io))
3433 PL_compiling.cop_io = PL_curcop->cop_io;
3435 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3436 SAVEFREESV(PL_compiling.cop_io);
3439 push_return(PL_op->op_next);
3440 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3441 PUSHEVAL(cx, 0, Nullgv);
3443 /* prepare to compile string */
3445 if (PERLDB_LINE && PL_curstash != PL_debstash)
3446 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3449 MUTEX_LOCK(&PL_eval_mutex);
3450 if (PL_eval_owner && PL_eval_owner != thr)
3451 while (PL_eval_owner)
3452 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3453 PL_eval_owner = thr;
3454 MUTEX_UNLOCK(&PL_eval_mutex);
3455 #endif /* USE_THREADS */
3456 ret = doeval(gimme, NULL);
3457 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3458 && ret != PL_op->op_next) { /* Successive compilation. */
3459 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3461 return DOCATCH(ret);
3471 register PERL_CONTEXT *cx;
3473 U8 save_flags = PL_op -> op_flags;
3478 retop = pop_return();
3481 if (gimme == G_VOID)
3483 else if (gimme == G_SCALAR) {
3486 if (SvFLAGS(TOPs) & SVs_TEMP)
3489 *MARK = sv_mortalcopy(TOPs);
3493 *MARK = &PL_sv_undef;
3498 /* in case LEAVE wipes old return values */
3499 for (mark = newsp + 1; mark <= SP; mark++) {
3500 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3501 *mark = sv_mortalcopy(*mark);
3502 TAINT_NOT; /* Each item is independent */
3506 PL_curpm = newpm; /* Don't pop $1 et al till now */
3509 assert(CvDEPTH(PL_compcv) == 1);
3511 CvDEPTH(PL_compcv) = 0;
3514 if (optype == OP_REQUIRE &&
3515 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3517 /* Unassume the success we assumed earlier. */
3518 SV *nsv = cx->blk_eval.old_namesv;
3519 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3520 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3521 /* die_where() did LEAVE, or we won't be here */
3525 if (!(save_flags & OPf_SPECIAL))
3535 register PERL_CONTEXT *cx;
3536 I32 gimme = GIMME_V;
3541 push_return(cLOGOP->op_other->op_next);
3542 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3545 PL_in_eval = EVAL_INEVAL;
3548 return DOCATCH(PL_op->op_next);
3558 register PERL_CONTEXT *cx;
3566 if (gimme == G_VOID)
3568 else if (gimme == G_SCALAR) {
3571 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3574 *MARK = sv_mortalcopy(TOPs);
3578 *MARK = &PL_sv_undef;
3583 /* in case LEAVE wipes old return values */
3584 for (mark = newsp + 1; mark <= SP; mark++) {
3585 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3586 *mark = sv_mortalcopy(*mark);
3587 TAINT_NOT; /* Each item is independent */
3591 PL_curpm = newpm; /* Don't pop $1 et al till now */
3599 S_doparseform(pTHX_ SV *sv)
3602 register char *s = SvPV_force(sv, len);
3603 register char *send = s + len;
3604 register char *base = Nullch;
3605 register I32 skipspaces = 0;
3606 bool noblank = FALSE;
3607 bool repeat = FALSE;
3608 bool postspace = FALSE;
3616 Perl_croak(aTHX_ "Null picture in formline");
3618 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3623 *fpc++ = FF_LINEMARK;
3624 noblank = repeat = FALSE;
3642 case ' ': case '\t':
3653 *fpc++ = FF_LITERAL;
3661 *fpc++ = skipspaces;
3665 *fpc++ = FF_NEWLINE;
3669 arg = fpc - linepc + 1;
3676 *fpc++ = FF_LINEMARK;
3677 noblank = repeat = FALSE;
3686 ischop = s[-1] == '^';
3692 arg = (s - base) - 1;
3694 *fpc++ = FF_LITERAL;
3703 *fpc++ = FF_LINEGLOB;
3705 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3706 arg = ischop ? 512 : 0;
3716 arg |= 256 + (s - f);
3718 *fpc++ = s - base; /* fieldsize for FETCH */
3719 *fpc++ = FF_DECIMAL;
3722 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3723 arg = ischop ? 512 : 0;
3725 s++; /* skip the '0' first */
3734 arg |= 256 + (s - f);
3736 *fpc++ = s - base; /* fieldsize for FETCH */
3737 *fpc++ = FF_0DECIMAL;
3742 bool ismore = FALSE;
3745 while (*++s == '>') ;
3746 prespace = FF_SPACE;
3748 else if (*s == '|') {
3749 while (*++s == '|') ;
3750 prespace = FF_HALFSPACE;
3755 while (*++s == '<') ;
3758 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3762 *fpc++ = s - base; /* fieldsize for FETCH */
3764 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3782 { /* need to jump to the next word */
3784 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3785 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3786 s = SvPVX(sv) + SvCUR(sv) + z;
3788 Copy(fops, s, arg, U16);
3790 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3795 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3797 * The original code was written in conjunction with BSD Computer Software
3798 * Research Group at University of California, Berkeley.
3800 * See also: "Optimistic Merge Sort" (SODA '92)
3802 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3804 * The code can be distributed under the same terms as Perl itself.
3809 #include <sys/types.h>
3814 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3815 #define Safefree(VAR) free(VAR)
3816 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3817 #endif /* TESTHARNESS */
3819 typedef char * aptr; /* pointer for arithmetic on sizes */
3820 typedef SV * gptr; /* pointers in our lists */
3822 /* Binary merge internal sort, with a few special mods
3823 ** for the special perl environment it now finds itself in.
3825 ** Things that were once options have been hotwired
3826 ** to values suitable for this use. In particular, we'll always
3827 ** initialize looking for natural runs, we'll always produce stable
3828 ** output, and we'll always do Peter McIlroy's binary merge.
3831 /* Pointer types for arithmetic and storage and convenience casts */
3833 #define APTR(P) ((aptr)(P))
3834 #define GPTP(P) ((gptr *)(P))
3835 #define GPPP(P) ((gptr **)(P))
3838 /* byte offset from pointer P to (larger) pointer Q */
3839 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3841 #define PSIZE sizeof(gptr)
3843 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3846 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3847 #define PNBYTE(N) ((N) << (PSHIFT))
3848 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3850 /* Leave optimization to compiler */
3851 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3852 #define PNBYTE(N) ((N) * (PSIZE))
3853 #define PINDEX(P, N) (GPTP(P) + (N))
3856 /* Pointer into other corresponding to pointer into this */
3857 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3859 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3862 /* Runs are identified by a pointer in the auxilliary list.
3863 ** The pointer is at the start of the list,
3864 ** and it points to the start of the next list.
3865 ** NEXT is used as an lvalue, too.
3868 #define NEXT(P) (*GPPP(P))
3871 /* PTHRESH is the minimum number of pairs with the same sense to justify
3872 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3873 ** not just elements, so PTHRESH == 8 means a run of 16.
3878 /* RTHRESH is the number of elements in a run that must compare low
3879 ** to the low element from the opposing run before we justify
3880 ** doing a binary rampup instead of single stepping.
3881 ** In random input, N in a row low should only happen with
3882 ** probability 2^(1-N), so we can risk that we are dealing
3883 ** with orderly input without paying much when we aren't.
3890 ** Overview of algorithm and variables.
3891 ** The array of elements at list1 will be organized into runs of length 2,
3892 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3893 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3895 ** Unless otherwise specified, pair pointers address the first of two elements.
3897 ** b and b+1 are a pair that compare with sense ``sense''.
3898 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3900 ** p2 parallels b in the list2 array, where runs are defined by
3903 ** t represents the ``top'' of the adjacent pairs that might extend
3904 ** the run beginning at b. Usually, t addresses a pair
3905 ** that compares with opposite sense from (b,b+1).
3906 ** However, it may also address a singleton element at the end of list1,
3907 ** or it may be equal to ``last'', the first element beyond list1.
3909 ** r addresses the Nth pair following b. If this would be beyond t,
3910 ** we back it off to t. Only when r is less than t do we consider the
3911 ** run long enough to consider checking.
3913 ** q addresses a pair such that the pairs at b through q already form a run.
3914 ** Often, q will equal b, indicating we only are sure of the pair itself.
3915 ** However, a search on the previous cycle may have revealed a longer run,
3916 ** so q may be greater than b.
3918 ** p is used to work back from a candidate r, trying to reach q,
3919 ** which would mean b through r would be a run. If we discover such a run,
3920 ** we start q at r and try to push it further towards t.
3921 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3922 ** In any event, after the check (if any), we have two main cases.
3924 ** 1) Short run. b <= q < p <= r <= t.
3925 ** b through q is a run (perhaps trivial)
3926 ** q through p are uninteresting pairs
3927 ** p through r is a run
3929 ** 2) Long run. b < r <= q < t.
3930 ** b through q is a run (of length >= 2 * PTHRESH)
3932 ** Note that degenerate cases are not only possible, but likely.
3933 ** For example, if the pair following b compares with opposite sense,
3934 ** then b == q < p == r == t.
3939 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3942 register gptr *b, *p, *q, *t, *p2;
3943 register gptr c, *last, *r;
3947 last = PINDEX(b, nmemb);
3948 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3949 for (p2 = list2; b < last; ) {
3950 /* We just started, or just reversed sense.
3951 ** Set t at end of pairs with the prevailing sense.
3953 for (p = b+2, t = p; ++p < last; t = ++p) {
3954 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3957 /* Having laid out the playing field, look for long runs */
3959 p = r = b + (2 * PTHRESH);
3960 if (r >= t) p = r = t; /* too short to care about */
3962 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3965 /* b through r is a (long) run.
3966 ** Extend it as far as possible.
3969 while (((p += 2) < t) &&
3970 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3971 r = p = q + 2; /* no simple pairs, no after-run */
3974 if (q > b) { /* run of greater than 2 at b */
3977 /* pick up singleton, if possible */
3979 ((t + 1) == last) &&
3980 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3981 savep = r = p = q = last;
3982 p2 = NEXT(p2) = p2 + (p - b);
3983 if (sense) while (b < --p) {
3990 while (q < p) { /* simple pairs */
3991 p2 = NEXT(p2) = p2 + 2;
3998 if (((b = p) == t) && ((t+1) == last)) {
4010 /* Overview of bmerge variables:
4012 ** list1 and list2 address the main and auxiliary arrays.
4013 ** They swap identities after each merge pass.
4014 ** Base points to the original list1, so we can tell if
4015 ** the pointers ended up where they belonged (or must be copied).
4017 ** When we are merging two lists, f1 and f2 are the next elements
4018 ** on the respective lists. l1 and l2 mark the end of the lists.
4019 ** tp2 is the current location in the merged list.
4021 ** p1 records where f1 started.
4022 ** After the merge, a new descriptor is built there.
4024 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4025 ** It is used to identify and delimit the runs.
4027 ** In the heat of determining where q, the greater of the f1/f2 elements,
4028 ** belongs in the other list, b, t and p, represent bottom, top and probe
4029 ** locations, respectively, in the other list.
4030 ** They make convenient temporary pointers in other places.
4034 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4038 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4039 gptr *aux, *list2, *p2, *last;
4043 if (nmemb <= 1) return; /* sorted trivially */
4044 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4046 dynprep(aTHX_ list1, list2, nmemb, cmp);
4047 last = PINDEX(list2, nmemb);
4048 while (NEXT(list2) != last) {
4049 /* More than one run remains. Do some merging to reduce runs. */
4051 for (tp2 = p2 = list2; p2 != last;) {
4052 /* The new first run begins where the old second list ended.
4053 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4057 f2 = l1 = POTHER(t, list2, list1);
4058 if (t != last) t = NEXT(t);
4059 l2 = POTHER(t, list2, list1);
4061 while (f1 < l1 && f2 < l2) {
4062 /* If head 1 is larger than head 2, find ALL the elements
4063 ** in list 2 strictly less than head1, write them all,
4064 ** then head 1. Then compare the new heads, and repeat,
4065 ** until one or both lists are exhausted.
4067 ** In all comparisons (after establishing
4068 ** which head to merge) the item to merge
4069 ** (at pointer q) is the first operand of
4070 ** the comparison. When we want to know
4071 ** if ``q is strictly less than the other'',
4073 ** cmp(q, other) < 0
4074 ** because stability demands that we treat equality
4075 ** as high when q comes from l2, and as low when
4076 ** q was from l1. So we ask the question by doing
4077 ** cmp(q, other) <= sense
4078 ** and make sense == 0 when equality should look low,
4079 ** and -1 when equality should look high.
4083 if (cmp(aTHX_ *f1, *f2) <= 0) {
4084 q = f2; b = f1; t = l1;
4087 q = f1; b = f2; t = l2;
4094 ** Leave t at something strictly
4095 ** greater than q (or at the end of the list),
4096 ** and b at something strictly less than q.
4098 for (i = 1, run = 0 ;;) {
4099 if ((p = PINDEX(b, i)) >= t) {
4101 if (((p = PINDEX(t, -1)) > b) &&
4102 (cmp(aTHX_ *q, *p) <= sense))
4106 } else if (cmp(aTHX_ *q, *p) <= sense) {
4110 if (++run >= RTHRESH) i += i;
4114 /* q is known to follow b and must be inserted before t.
4115 ** Increment b, so the range of possibilities is [b,t).
4116 ** Round binary split down, to favor early appearance.
4117 ** Adjust b and t until q belongs just before t.
4122 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4123 if (cmp(aTHX_ *q, *p) <= sense) {
4129 /* Copy all the strictly low elements */
4132 FROMTOUPTO(f2, tp2, t);
4135 FROMTOUPTO(f1, tp2, t);
4141 /* Run out remaining list */
4143 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4144 } else FROMTOUPTO(f1, tp2, l1);
4145 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4150 last = PINDEX(list2, nmemb);
4152 if (base == list2) {
4153 last = PINDEX(list1, nmemb);
4154 FROMTOUPTO(list1, list2, last);
4169 sortcv(pTHXo_ SV *a, SV *b)
4171 I32 oldsaveix = PL_savestack_ix;
4172 I32 oldscopeix = PL_scopestack_ix;
4174 GvSV(PL_firstgv) = a;
4175 GvSV(PL_secondgv) = b;
4176 PL_stack_sp = PL_stack_base;
4179 if (PL_stack_sp != PL_stack_base + 1)
4180 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4181 if (!SvNIOKp(*PL_stack_sp))
4182 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4183 result = SvIV(*PL_stack_sp);
4184 while (PL_scopestack_ix > oldscopeix) {
4187 leave_scope(oldsaveix);
4192 sortcv_stacked(pTHXo_ SV *a, SV *b)
4194 I32 oldsaveix = PL_savestack_ix;
4195 I32 oldscopeix = PL_scopestack_ix;
4200 av = (AV*)PL_curpad[0];
4202 av = GvAV(PL_defgv);
4205 if (AvMAX(av) < 1) {
4206 SV** ary = AvALLOC(av);
4207 if (AvARRAY(av) != ary) {
4208 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4209 SvPVX(av) = (char*)ary;
4211 if (AvMAX(av) < 1) {
4214 SvPVX(av) = (char*)ary;
4221 PL_stack_sp = PL_stack_base;
4224 if (PL_stack_sp != PL_stack_base + 1)
4225 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4226 if (!SvNIOKp(*PL_stack_sp))
4227 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4228 result = SvIV(*PL_stack_sp);
4229 while (PL_scopestack_ix > oldscopeix) {
4232 leave_scope(oldsaveix);
4237 sortcv_xsub(pTHXo_ SV *a, SV *b)
4240 I32 oldsaveix = PL_savestack_ix;
4241 I32 oldscopeix = PL_scopestack_ix;
4243 CV *cv=(CV*)PL_sortcop;
4251 (void)(*CvXSUB(cv))(aTHXo_ cv);
4252 if (PL_stack_sp != PL_stack_base + 1)
4253 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4254 if (!SvNIOKp(*PL_stack_sp))
4255 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4256 result = SvIV(*PL_stack_sp);
4257 while (PL_scopestack_ix > oldscopeix) {
4260 leave_scope(oldsaveix);
4266 sv_ncmp(pTHXo_ SV *a, SV *b)
4270 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4274 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4278 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4280 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4282 if (PL_amagic_generation) { \
4283 if (SvAMAGIC(left)||SvAMAGIC(right))\
4284 *svp = amagic_call(left, \
4292 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4295 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4300 I32 i = SvIVX(tmpsv);
4310 return sv_ncmp(aTHXo_ a, b);
4314 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4317 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4322 I32 i = SvIVX(tmpsv);
4332 return sv_i_ncmp(aTHXo_ a, b);
4336 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4339 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4344 I32 i = SvIVX(tmpsv);
4354 return sv_cmp(str1, str2);
4358 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4361 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4366 I32 i = SvIVX(tmpsv);
4376 return sv_cmp_locale(str1, str2);
4380 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4382 SV *datasv = FILTER_DATA(idx);
4383 int filter_has_file = IoLINES(datasv);
4384 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4385 SV *filter_state = (SV *)IoTOP_GV(datasv);
4386 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4389 /* I was having segfault trouble under Linux 2.2.5 after a
4390 parse error occured. (Had to hack around it with a test
4391 for PL_error_count == 0.) Solaris doesn't segfault --
4392 not sure where the trouble is yet. XXX */
4394 if (filter_has_file) {
4395 len = FILTER_READ(idx+1, buf_sv, maxlen);
4398 if (filter_sub && len >= 0) {
4409 PUSHs(sv_2mortal(newSViv(maxlen)));
4411 PUSHs(filter_state);
4414 count = call_sv(filter_sub, G_SCALAR);
4430 IoLINES(datasv) = 0;
4431 if (filter_child_proc) {
4432 SvREFCNT_dec(filter_child_proc);
4433 IoFMT_GV(datasv) = Nullgv;
4436 SvREFCNT_dec(filter_state);
4437 IoTOP_GV(datasv) = Nullgv;
4440 SvREFCNT_dec(filter_sub);
4441 IoBOTTOM_GV(datasv) = Nullgv;
4443 filter_del(run_user_filter);
4452 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4454 return sv_cmp_locale(str1, str2);
4458 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4460 return sv_cmp(str1, str2);
4463 #endif /* PERL_OBJECT */