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_5005THREADS)
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_5005THREADS)
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_5005THREADS */
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;
997 #ifdef USE_5005THREADS
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];
1019 #ifndef USE_5005THREADS
1020 cx->blk_sub.savearray = GvAV(PL_defgv);
1021 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1022 #endif /* USE_5005THREADS */
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",
1201 if (ckWARN(WARN_EXITING))
1202 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1206 if (ckWARN(WARN_EXITING))
1207 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1216 if (ckWARN(WARN_EXITING))
1217 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
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",
1336 if (ckWARN(WARN_EXITING))
1337 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1341 if (ckWARN(WARN_EXITING))
1342 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1346 if (ckWARN(WARN_EXITING))
1347 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1351 if (ckWARN(WARN_EXITING))
1352 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
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) {
1569 if (PL_DBsub && cxix >= 0 &&
1570 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1574 cxix = dopoptosub_at(ccstack, cxix - 1);
1577 cx = &ccstack[cxix];
1578 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1579 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1580 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1581 field below is defined for any cx. */
1582 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1583 cx = &ccstack[dbcxix];
1586 stashname = CopSTASHPV(cx->blk_oldcop);
1587 if (GIMME != G_ARRAY) {
1590 PUSHs(&PL_sv_undef);
1593 sv_setpv(TARG, stashname);
1602 PUSHs(&PL_sv_undef);
1604 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1605 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1606 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1609 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1610 /* So is ccstack[dbcxix]. */
1612 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1613 PUSHs(sv_2mortal(sv));
1614 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1617 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1618 PUSHs(sv_2mortal(newSViv(0)));
1620 gimme = (I32)cx->blk_gimme;
1621 if (gimme == G_VOID)
1622 PUSHs(&PL_sv_undef);
1624 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1625 if (CxTYPE(cx) == CXt_EVAL) {
1627 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1628 PUSHs(cx->blk_eval.cur_text);
1632 else if (cx->blk_eval.old_namesv) {
1633 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1636 /* eval BLOCK (try blocks have old_namesv == 0) */
1638 PUSHs(&PL_sv_undef);
1639 PUSHs(&PL_sv_undef);
1643 PUSHs(&PL_sv_undef);
1644 PUSHs(&PL_sv_undef);
1646 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1647 && CopSTASH_eq(PL_curcop, PL_debstash))
1649 AV *ary = cx->blk_sub.argarray;
1650 int off = AvARRAY(ary) - AvALLOC(ary);
1654 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1657 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1660 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1661 av_extend(PL_dbargs, AvFILLp(ary) + off);
1662 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1663 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1665 /* XXX only hints propagated via op_private are currently
1666 * visible (others are not easily accessible, since they
1667 * use the global PL_hints) */
1668 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1669 HINT_PRIVATE_MASK)));
1672 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1674 if (old_warnings == pWARN_NONE ||
1675 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1676 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1677 else if (old_warnings == pWARN_ALL ||
1678 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1679 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1681 mask = newSVsv(old_warnings);
1682 PUSHs(sv_2mortal(mask));
1697 sv_reset(tmps, CopSTASH(PL_curcop));
1709 PL_curcop = (COP*)PL_op;
1710 TAINT_NOT; /* Each statement is presumed innocent */
1711 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1714 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1718 register PERL_CONTEXT *cx;
1719 I32 gimme = G_ARRAY;
1726 DIE(aTHX_ "No DB::DB routine defined");
1728 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1729 /* don't do recursive DB::DB call */
1741 push_return(PL_op->op_next);
1742 PUSHBLOCK(cx, CXt_SUB, SP);
1745 (void)SvREFCNT_inc(cv);
1746 SAVEVPTR(PL_curpad);
1747 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1748 RETURNOP(CvSTART(cv));
1762 register PERL_CONTEXT *cx;
1763 I32 gimme = GIMME_V;
1765 U32 cxtype = CXt_LOOP;
1773 #ifdef USE_5005THREADS
1774 if (PL_op->op_flags & OPf_SPECIAL) {
1775 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1776 SAVEGENERICSV(*svp);
1780 #endif /* USE_5005THREADS */
1781 if (PL_op->op_targ) {
1782 #ifndef USE_ITHREADS
1783 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1786 SAVEPADSV(PL_op->op_targ);
1787 iterdata = (void*)PL_op->op_targ;
1788 cxtype |= CXp_PADVAR;
1793 svp = &GvSV(gv); /* symbol table variable */
1794 SAVEGENERICSV(*svp);
1797 iterdata = (void*)gv;
1803 PUSHBLOCK(cx, cxtype, SP);
1805 PUSHLOOP(cx, iterdata, MARK);
1807 PUSHLOOP(cx, svp, MARK);
1809 if (PL_op->op_flags & OPf_STACKED) {
1810 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1811 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1813 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1814 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1815 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1816 looks_like_number((SV*)cx->blk_loop.iterary) &&
1817 *SvPVX(cx->blk_loop.iterary) != '0'))
1819 if (SvNV(sv) < IV_MIN ||
1820 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1821 DIE(aTHX_ "Range iterator outside integer range");
1822 cx->blk_loop.iterix = SvIV(sv);
1823 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1826 cx->blk_loop.iterlval = newSVsv(sv);
1830 cx->blk_loop.iterary = PL_curstack;
1831 AvFILLp(PL_curstack) = SP - PL_stack_base;
1832 cx->blk_loop.iterix = MARK - PL_stack_base;
1841 register PERL_CONTEXT *cx;
1842 I32 gimme = GIMME_V;
1848 PUSHBLOCK(cx, CXt_LOOP, SP);
1849 PUSHLOOP(cx, 0, SP);
1857 register PERL_CONTEXT *cx;
1865 newsp = PL_stack_base + cx->blk_loop.resetsp;
1868 if (gimme == G_VOID)
1870 else if (gimme == G_SCALAR) {
1872 *++newsp = sv_mortalcopy(*SP);
1874 *++newsp = &PL_sv_undef;
1878 *++newsp = sv_mortalcopy(*++mark);
1879 TAINT_NOT; /* Each item is independent */
1885 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1886 PL_curpm = newpm; /* ... and pop $1 et al */
1898 register PERL_CONTEXT *cx;
1899 bool popsub2 = FALSE;
1900 bool clear_errsv = FALSE;
1907 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1908 if (cxstack_ix == PL_sortcxix
1909 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1911 if (cxstack_ix > PL_sortcxix)
1912 dounwind(PL_sortcxix);
1913 AvARRAY(PL_curstack)[1] = *SP;
1914 PL_stack_sp = PL_stack_base + 1;
1919 cxix = dopoptosub(cxstack_ix);
1921 DIE(aTHX_ "Can't return outside a subroutine");
1922 if (cxix < cxstack_ix)
1926 switch (CxTYPE(cx)) {
1931 if (!(PL_in_eval & EVAL_KEEPERR))
1937 if (optype == OP_REQUIRE &&
1938 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1940 /* Unassume the success we assumed earlier. */
1941 SV *nsv = cx->blk_eval.old_namesv;
1942 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1943 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1950 DIE(aTHX_ "panic: return");
1954 if (gimme == G_SCALAR) {
1957 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1959 *++newsp = SvREFCNT_inc(*SP);
1964 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1966 *++newsp = sv_mortalcopy(sv);
1971 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1974 *++newsp = sv_mortalcopy(*SP);
1977 *++newsp = &PL_sv_undef;
1979 else if (gimme == G_ARRAY) {
1980 while (++MARK <= SP) {
1981 *++newsp = (popsub2 && SvTEMP(*MARK))
1982 ? *MARK : sv_mortalcopy(*MARK);
1983 TAINT_NOT; /* Each item is independent */
1986 PL_stack_sp = newsp;
1988 /* Stack values are safe: */
1990 POPSUB(cx,sv); /* release CV and @_ ... */
1994 PL_curpm = newpm; /* ... and pop $1 et al */
2000 return pop_return();
2007 register PERL_CONTEXT *cx;
2017 if (PL_op->op_flags & OPf_SPECIAL) {
2018 cxix = dopoptoloop(cxstack_ix);
2020 DIE(aTHX_ "Can't \"last\" outside a loop block");
2023 cxix = dopoptolabel(cPVOP->op_pv);
2025 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2027 if (cxix < cxstack_ix)
2032 switch (CxTYPE(cx)) {
2035 newsp = PL_stack_base + cx->blk_loop.resetsp;
2036 nextop = cx->blk_loop.last_op->op_next;
2040 nextop = pop_return();
2044 nextop = pop_return();
2048 nextop = pop_return();
2051 DIE(aTHX_ "panic: last");
2055 if (gimme == G_SCALAR) {
2057 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2058 ? *SP : sv_mortalcopy(*SP);
2060 *++newsp = &PL_sv_undef;
2062 else if (gimme == G_ARRAY) {
2063 while (++MARK <= SP) {
2064 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2065 ? *MARK : sv_mortalcopy(*MARK);
2066 TAINT_NOT; /* Each item is independent */
2072 /* Stack values are safe: */
2075 POPLOOP(cx); /* release loop vars ... */
2079 POPSUB(cx,sv); /* release CV and @_ ... */
2082 PL_curpm = newpm; /* ... and pop $1 et al */
2092 register PERL_CONTEXT *cx;
2095 if (PL_op->op_flags & OPf_SPECIAL) {
2096 cxix = dopoptoloop(cxstack_ix);
2098 DIE(aTHX_ "Can't \"next\" outside a loop block");
2101 cxix = dopoptolabel(cPVOP->op_pv);
2103 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2105 if (cxix < cxstack_ix)
2108 /* clear off anything above the scope we're re-entering, but
2109 * save the rest until after a possible continue block */
2110 inner = PL_scopestack_ix;
2112 if (PL_scopestack_ix < inner)
2113 leave_scope(PL_scopestack[PL_scopestack_ix]);
2114 return cx->blk_loop.next_op;
2120 register PERL_CONTEXT *cx;
2123 if (PL_op->op_flags & OPf_SPECIAL) {
2124 cxix = dopoptoloop(cxstack_ix);
2126 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2129 cxix = dopoptolabel(cPVOP->op_pv);
2131 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2133 if (cxix < cxstack_ix)
2137 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2138 LEAVE_SCOPE(oldsave);
2139 return cx->blk_loop.redo_op;
2143 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2147 static char too_deep[] = "Target of goto is too deeply nested";
2150 Perl_croak(aTHX_ too_deep);
2151 if (o->op_type == OP_LEAVE ||
2152 o->op_type == OP_SCOPE ||
2153 o->op_type == OP_LEAVELOOP ||
2154 o->op_type == OP_LEAVETRY)
2156 *ops++ = cUNOPo->op_first;
2158 Perl_croak(aTHX_ too_deep);
2161 if (o->op_flags & OPf_KIDS) {
2162 /* First try all the kids at this level, since that's likeliest. */
2163 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2164 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2165 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2168 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2169 if (kid == PL_lastgotoprobe)
2171 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2173 (ops[-1]->op_type != OP_NEXTSTATE &&
2174 ops[-1]->op_type != OP_DBSTATE)))
2176 if ((o = dofindlabel(kid, label, ops, oplimit)))
2195 register PERL_CONTEXT *cx;
2196 #define GOTO_DEPTH 64
2197 OP *enterops[GOTO_DEPTH];
2199 int do_dump = (PL_op->op_type == OP_DUMP);
2200 static char must_have_label[] = "goto must have label";
2203 if (PL_op->op_flags & OPf_STACKED) {
2207 /* This egregious kludge implements goto &subroutine */
2208 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2210 register PERL_CONTEXT *cx;
2211 CV* cv = (CV*)SvRV(sv);
2217 if (!CvROOT(cv) && !CvXSUB(cv)) {
2222 /* autoloaded stub? */
2223 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2225 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2226 GvNAMELEN(gv), FALSE);
2227 if (autogv && (cv = GvCV(autogv)))
2229 tmpstr = sv_newmortal();
2230 gv_efullname3(tmpstr, gv, Nullch);
2231 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2233 DIE(aTHX_ "Goto undefined subroutine");
2236 /* First do some returnish stuff. */
2237 cxix = dopoptosub(cxstack_ix);
2239 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2240 if (cxix < cxstack_ix)
2244 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2246 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2247 /* put @_ back onto stack */
2248 AV* av = cx->blk_sub.argarray;
2250 items = AvFILLp(av) + 1;
2252 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2253 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2254 PL_stack_sp += items;
2255 #ifndef USE_5005THREADS
2256 SvREFCNT_dec(GvAV(PL_defgv));
2257 GvAV(PL_defgv) = cx->blk_sub.savearray;
2258 #endif /* USE_5005THREADS */
2259 /* abandon @_ if it got reified */
2261 (void)sv_2mortal((SV*)av); /* delay until return */
2263 av_extend(av, items-1);
2264 AvFLAGS(av) = AVf_REIFY;
2265 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2268 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2270 #ifdef USE_5005THREADS
2271 av = (AV*)PL_curpad[0];
2273 av = GvAV(PL_defgv);
2275 items = AvFILLp(av) + 1;
2277 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2278 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2279 PL_stack_sp += items;
2281 if (CxTYPE(cx) == CXt_SUB &&
2282 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2283 SvREFCNT_dec(cx->blk_sub.cv);
2284 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2285 LEAVE_SCOPE(oldsave);
2287 /* Now do some callish stuff. */
2290 #ifdef PERL_XSUB_OLDSTYLE
2291 if (CvOLDSTYLE(cv)) {
2292 I32 (*fp3)(int,int,int);
2297 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2298 items = (*fp3)(CvXSUBANY(cv).any_i32,
2299 mark - PL_stack_base + 1,
2301 SP = PL_stack_base + items;
2304 #endif /* PERL_XSUB_OLDSTYLE */
2309 PL_stack_sp--; /* There is no cv arg. */
2310 /* Push a mark for the start of arglist */
2312 (void)(*CvXSUB(cv))(aTHXo_ cv);
2313 /* Pop the current context like a decent sub should */
2314 POPBLOCK(cx, PL_curpm);
2315 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2318 return pop_return();
2321 AV* padlist = CvPADLIST(cv);
2322 SV** svp = AvARRAY(padlist);
2323 if (CxTYPE(cx) == CXt_EVAL) {
2324 PL_in_eval = cx->blk_eval.old_in_eval;
2325 PL_eval_root = cx->blk_eval.old_eval_root;
2326 cx->cx_type = CXt_SUB;
2327 cx->blk_sub.hasargs = 0;
2329 cx->blk_sub.cv = cv;
2330 cx->blk_sub.olddepth = CvDEPTH(cv);
2332 if (CvDEPTH(cv) < 2)
2333 (void)SvREFCNT_inc(cv);
2334 else { /* save temporaries on recursion? */
2335 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2336 sub_crush_depth(cv);
2337 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2338 AV *newpad = newAV();
2339 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2340 I32 ix = AvFILLp((AV*)svp[1]);
2341 I32 names_fill = AvFILLp((AV*)svp[0]);
2342 svp = AvARRAY(svp[0]);
2343 for ( ;ix > 0; ix--) {
2344 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2345 char *name = SvPVX(svp[ix]);
2346 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2349 /* outer lexical or anon code */
2350 av_store(newpad, ix,
2351 SvREFCNT_inc(oldpad[ix]) );
2353 else { /* our own lexical */
2355 av_store(newpad, ix, sv = (SV*)newAV());
2356 else if (*name == '%')
2357 av_store(newpad, ix, sv = (SV*)newHV());
2359 av_store(newpad, ix, sv = NEWSV(0,0));
2363 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2364 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2367 av_store(newpad, ix, sv = NEWSV(0,0));
2371 if (cx->blk_sub.hasargs) {
2374 av_store(newpad, 0, (SV*)av);
2375 AvFLAGS(av) = AVf_REIFY;
2377 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2378 AvFILLp(padlist) = CvDEPTH(cv);
2379 svp = AvARRAY(padlist);
2382 #ifdef USE_5005THREADS
2383 if (!cx->blk_sub.hasargs) {
2384 AV* av = (AV*)PL_curpad[0];
2386 items = AvFILLp(av) + 1;
2388 /* Mark is at the end of the stack. */
2390 Copy(AvARRAY(av), SP + 1, items, SV*);
2395 #endif /* USE_5005THREADS */
2396 SAVEVPTR(PL_curpad);
2397 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2398 #ifndef USE_5005THREADS
2399 if (cx->blk_sub.hasargs)
2400 #endif /* USE_5005THREADS */
2402 AV* av = (AV*)PL_curpad[0];
2405 #ifndef USE_5005THREADS
2406 cx->blk_sub.savearray = GvAV(PL_defgv);
2407 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2408 #endif /* USE_5005THREADS */
2409 cx->blk_sub.oldcurpad = PL_curpad;
2410 cx->blk_sub.argarray = av;
2413 if (items >= AvMAX(av) + 1) {
2415 if (AvARRAY(av) != ary) {
2416 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2417 SvPVX(av) = (char*)ary;
2419 if (items >= AvMAX(av) + 1) {
2420 AvMAX(av) = items - 1;
2421 Renew(ary,items+1,SV*);
2423 SvPVX(av) = (char*)ary;
2426 Copy(mark,AvARRAY(av),items,SV*);
2427 AvFILLp(av) = items - 1;
2428 assert(!AvREAL(av));
2435 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2437 * We do not care about using sv to call CV;
2438 * it's for informational purposes only.
2440 SV *sv = GvSV(PL_DBsub);
2443 if (PERLDB_SUB_NN) {
2444 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2447 gv_efullname3(sv, CvGV(cv), Nullch);
2450 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2451 PUSHMARK( PL_stack_sp );
2452 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2456 RETURNOP(CvSTART(cv));
2460 label = SvPV(sv,n_a);
2461 if (!(do_dump || *label))
2462 DIE(aTHX_ must_have_label);
2465 else if (PL_op->op_flags & OPf_SPECIAL) {
2467 DIE(aTHX_ must_have_label);
2470 label = cPVOP->op_pv;
2472 if (label && *label) {
2474 bool leaving_eval = FALSE;
2475 PERL_CONTEXT *last_eval_cx = 0;
2479 PL_lastgotoprobe = 0;
2481 for (ix = cxstack_ix; ix >= 0; ix--) {
2483 switch (CxTYPE(cx)) {
2485 leaving_eval = TRUE;
2486 if (CxREALEVAL(cx)) {
2487 gotoprobe = (last_eval_cx ?
2488 last_eval_cx->blk_eval.old_eval_root :
2493 /* else fall through */
2495 gotoprobe = cx->blk_oldcop->op_sibling;
2501 gotoprobe = cx->blk_oldcop->op_sibling;
2503 gotoprobe = PL_main_root;
2506 if (CvDEPTH(cx->blk_sub.cv)) {
2507 gotoprobe = CvROOT(cx->blk_sub.cv);
2513 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2516 DIE(aTHX_ "panic: goto");
2517 gotoprobe = PL_main_root;
2521 retop = dofindlabel(gotoprobe, label,
2522 enterops, enterops + GOTO_DEPTH);
2526 PL_lastgotoprobe = gotoprobe;
2529 DIE(aTHX_ "Can't find label %s", label);
2531 /* if we're leaving an eval, check before we pop any frames
2532 that we're not going to punt, otherwise the error
2535 if (leaving_eval && *enterops && enterops[1]) {
2537 for (i = 1; enterops[i]; i++)
2538 if (enterops[i]->op_type == OP_ENTERITER)
2539 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2542 /* pop unwanted frames */
2544 if (ix < cxstack_ix) {
2551 oldsave = PL_scopestack[PL_scopestack_ix];
2552 LEAVE_SCOPE(oldsave);
2555 /* push wanted frames */
2557 if (*enterops && enterops[1]) {
2559 for (ix = 1; enterops[ix]; ix++) {
2560 PL_op = enterops[ix];
2561 /* Eventually we may want to stack the needed arguments
2562 * for each op. For now, we punt on the hard ones. */
2563 if (PL_op->op_type == OP_ENTERITER)
2564 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2565 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2573 if (!retop) retop = PL_main_start;
2575 PL_restartop = retop;
2576 PL_do_undump = TRUE;
2580 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2581 PL_do_undump = FALSE;
2597 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2601 PL_exit_flags |= PERL_EXIT_EXPECTED;
2603 PUSHs(&PL_sv_undef);
2611 NV value = SvNVx(GvSV(cCOP->cop_gv));
2612 register I32 match = I_32(value);
2615 if (((NV)match) > value)
2616 --match; /* was fractional--truncate other way */
2618 match -= cCOP->uop.scop.scop_offset;
2621 else if (match > cCOP->uop.scop.scop_max)
2622 match = cCOP->uop.scop.scop_max;
2623 PL_op = cCOP->uop.scop.scop_next[match];
2633 PL_op = PL_op->op_next; /* can't assume anything */
2636 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2637 match -= cCOP->uop.scop.scop_offset;
2640 else if (match > cCOP->uop.scop.scop_max)
2641 match = cCOP->uop.scop.scop_max;
2642 PL_op = cCOP->uop.scop.scop_next[match];
2651 S_save_lines(pTHX_ AV *array, SV *sv)
2653 register char *s = SvPVX(sv);
2654 register char *send = SvPVX(sv) + SvCUR(sv);
2656 register I32 line = 1;
2658 while (s && s < send) {
2659 SV *tmpstr = NEWSV(85,0);
2661 sv_upgrade(tmpstr, SVt_PVMG);
2662 t = strchr(s, '\n');
2668 sv_setpvn(tmpstr, s, t - s);
2669 av_store(array, line++, tmpstr);
2674 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2676 S_docatch_body(pTHX_ va_list args)
2678 return docatch_body();
2683 S_docatch_body(pTHX)
2690 S_docatch(pTHX_ OP *o)
2694 volatile PERL_SI *cursi = PL_curstackinfo;
2698 assert(CATCH_GET == TRUE);
2701 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2703 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2709 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2715 if (PL_restartop && cursi == PL_curstackinfo) {
2716 PL_op = PL_restartop;
2733 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2734 /* sv Text to convert to OP tree. */
2735 /* startop op_free() this to undo. */
2736 /* code Short string id of the caller. */
2738 dSP; /* Make POPBLOCK work. */
2741 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2745 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2746 char *tmpbuf = tbuf;
2752 /* switch to eval mode */
2754 if (PL_curcop == &PL_compiling) {
2755 SAVECOPSTASH_FREE(&PL_compiling);
2756 CopSTASH_set(&PL_compiling, PL_curstash);
2758 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2759 SV *sv = sv_newmortal();
2760 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2761 code, (unsigned long)++PL_evalseq,
2762 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2766 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2767 SAVECOPFILE_FREE(&PL_compiling);
2768 CopFILE_set(&PL_compiling, tmpbuf+2);
2769 SAVECOPLINE(&PL_compiling);
2770 CopLINE_set(&PL_compiling, 1);
2771 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2772 deleting the eval's FILEGV from the stash before gv_check() runs
2773 (i.e. before run-time proper). To work around the coredump that
2774 ensues, we always turn GvMULTI_on for any globals that were
2775 introduced within evals. See force_ident(). GSAR 96-10-12 */
2776 safestr = savepv(tmpbuf);
2777 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2779 #ifdef OP_IN_REGISTER
2784 PL_hints &= HINT_UTF8;
2787 PL_op->op_type = OP_ENTEREVAL;
2788 PL_op->op_flags = 0; /* Avoid uninit warning. */
2789 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2790 PUSHEVAL(cx, 0, Nullgv);
2791 rop = doeval(G_SCALAR, startop);
2792 POPBLOCK(cx,PL_curpm);
2795 (*startop)->op_type = OP_NULL;
2796 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2798 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2800 if (PL_curcop == &PL_compiling)
2801 PL_compiling.op_private = PL_hints;
2802 #ifdef OP_IN_REGISTER
2808 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2810 S_doeval(pTHX_ int gimme, OP** startop)
2818 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2819 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2824 /* set up a scratch pad */
2827 SAVEVPTR(PL_curpad);
2828 SAVESPTR(PL_comppad);
2829 SAVESPTR(PL_comppad_name);
2830 SAVEI32(PL_comppad_name_fill);
2831 SAVEI32(PL_min_intro_pending);
2832 SAVEI32(PL_max_intro_pending);
2835 for (i = cxstack_ix - 1; i >= 0; i--) {
2836 PERL_CONTEXT *cx = &cxstack[i];
2837 if (CxTYPE(cx) == CXt_EVAL)
2839 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2840 caller = cx->blk_sub.cv;
2845 SAVESPTR(PL_compcv);
2846 PL_compcv = (CV*)NEWSV(1104,0);
2847 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2848 CvEVAL_on(PL_compcv);
2849 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2850 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2852 #ifdef USE_5005THREADS
2853 CvOWNER(PL_compcv) = 0;
2854 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2855 MUTEX_INIT(CvMUTEXP(PL_compcv));
2856 #endif /* USE_5005THREADS */
2858 PL_comppad = newAV();
2859 av_push(PL_comppad, Nullsv);
2860 PL_curpad = AvARRAY(PL_comppad);
2861 PL_comppad_name = newAV();
2862 PL_comppad_name_fill = 0;
2863 PL_min_intro_pending = 0;
2865 #ifdef USE_5005THREADS
2866 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2867 PL_curpad[0] = (SV*)newAV();
2868 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2869 #endif /* USE_5005THREADS */
2871 comppadlist = newAV();
2872 AvREAL_off(comppadlist);
2873 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2874 av_store(comppadlist, 1, (SV*)PL_comppad);
2875 CvPADLIST(PL_compcv) = comppadlist;
2878 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2880 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2883 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2885 /* make sure we compile in the right package */
2887 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2888 SAVESPTR(PL_curstash);
2889 PL_curstash = CopSTASH(PL_curcop);
2891 SAVESPTR(PL_beginav);
2892 PL_beginav = newAV();
2893 SAVEFREESV(PL_beginav);
2894 SAVEI32(PL_error_count);
2896 /* try to compile it */
2898 PL_eval_root = Nullop;
2900 PL_curcop = &PL_compiling;
2901 PL_curcop->cop_arybase = 0;
2902 SvREFCNT_dec(PL_rs);
2903 PL_rs = newSVpvn("\n", 1);
2904 if (saveop && saveop->op_flags & OPf_SPECIAL)
2905 PL_in_eval |= EVAL_KEEPERR;
2908 if (yyparse() || PL_error_count || !PL_eval_root) {
2912 I32 optype = 0; /* Might be reset by POPEVAL. */
2917 op_free(PL_eval_root);
2918 PL_eval_root = Nullop;
2920 SP = PL_stack_base + POPMARK; /* pop original mark */
2922 POPBLOCK(cx,PL_curpm);
2928 if (optype == OP_REQUIRE) {
2929 char* msg = SvPVx(ERRSV, n_a);
2930 DIE(aTHX_ "%sCompilation failed in require",
2931 *msg ? msg : "Unknown error\n");
2934 char* msg = SvPVx(ERRSV, n_a);
2936 POPBLOCK(cx,PL_curpm);
2938 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2939 (*msg ? msg : "Unknown error\n"));
2941 SvREFCNT_dec(PL_rs);
2942 PL_rs = SvREFCNT_inc(PL_nrs);
2943 #ifdef USE_5005THREADS
2944 MUTEX_LOCK(&PL_eval_mutex);
2946 COND_SIGNAL(&PL_eval_cond);
2947 MUTEX_UNLOCK(&PL_eval_mutex);
2948 #endif /* USE_5005THREADS */
2951 SvREFCNT_dec(PL_rs);
2952 PL_rs = SvREFCNT_inc(PL_nrs);
2953 CopLINE_set(&PL_compiling, 0);
2955 *startop = PL_eval_root;
2956 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2957 CvOUTSIDE(PL_compcv) = Nullcv;
2959 SAVEFREEOP(PL_eval_root);
2961 scalarvoid(PL_eval_root);
2962 else if (gimme & G_ARRAY)
2965 scalar(PL_eval_root);
2967 DEBUG_x(dump_eval());
2969 /* Register with debugger: */
2970 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2971 CV *cv = get_cv("DB::postponed", FALSE);
2975 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2977 call_sv((SV*)cv, G_DISCARD);
2981 /* compiled okay, so do it */
2983 CvDEPTH(PL_compcv) = 1;
2984 SP = PL_stack_base + POPMARK; /* pop original mark */
2985 PL_op = saveop; /* The caller may need it. */
2986 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2987 #ifdef USE_5005THREADS
2988 MUTEX_LOCK(&PL_eval_mutex);
2990 COND_SIGNAL(&PL_eval_cond);
2991 MUTEX_UNLOCK(&PL_eval_mutex);
2992 #endif /* USE_5005THREADS */
2994 RETURNOP(PL_eval_start);
2998 S_doopen_pmc(pTHX_ const char *name, const char *mode)
3000 STRLEN namelen = strlen(name);
3003 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3004 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3005 char *pmc = SvPV_nolen(pmcsv);
3008 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3009 fp = PerlIO_open(name, mode);
3012 if (PerlLIO_stat(name, &pmstat) < 0 ||
3013 pmstat.st_mtime < pmcstat.st_mtime)
3015 fp = PerlIO_open(pmc, mode);
3018 fp = PerlIO_open(name, mode);
3021 SvREFCNT_dec(pmcsv);
3024 fp = PerlIO_open(name, mode);
3032 register PERL_CONTEXT *cx;
3036 char *tryname = Nullch;
3037 SV *namesv = Nullsv;
3039 I32 gimme = GIMME_V;
3040 PerlIO *tryrsfp = 0;
3042 int filter_has_file = 0;
3043 GV *filter_child_proc = 0;
3044 SV *filter_state = 0;
3049 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3050 UV rev = 0, ver = 0, sver = 0;
3052 U8 *s = (U8*)SvPVX(sv);
3053 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3055 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3058 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3061 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3064 if (PERL_REVISION < rev
3065 || (PERL_REVISION == rev
3066 && (PERL_VERSION < ver
3067 || (PERL_VERSION == ver
3068 && PERL_SUBVERSION < sver))))
3070 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3071 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3072 PERL_VERSION, PERL_SUBVERSION);
3076 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3077 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3078 + ((NV)PERL_SUBVERSION/(NV)1000000)
3079 + 0.00000099 < SvNV(sv))
3083 NV nver = (nrev - rev) * 1000;
3084 UV ver = (UV)(nver + 0.0009);
3085 NV nsver = (nver - ver) * 1000;
3086 UV sver = (UV)(nsver + 0.0009);
3088 /* help out with the "use 5.6" confusion */
3089 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3090 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3091 "this is only v%d.%d.%d, stopped"
3092 " (did you mean v%"UVuf".%"UVuf".0?)",
3093 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3094 PERL_SUBVERSION, rev, ver/100);
3097 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3098 "this is only v%d.%d.%d, stopped",
3099 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3106 name = SvPV(sv, len);
3107 if (!(name && len > 0 && *name))
3108 DIE(aTHX_ "Null filename used");
3109 TAINT_PROPER("require");
3110 if (PL_op->op_type == OP_REQUIRE &&
3111 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3112 *svp != &PL_sv_undef)
3115 /* prepare to compile file */
3117 #ifdef MACOS_TRADITIONAL
3118 if (PERL_FILE_IS_ABSOLUTE(name)
3119 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3122 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3123 /* We consider paths of the form :a:b ambiguous and interpret them first
3124 as global then as local
3126 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3132 if (PERL_FILE_IS_ABSOLUTE(name)
3133 || (*name == '.' && (name[1] == '/' ||
3134 (name[1] == '.' && name[2] == '/'))))
3137 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3141 AV *ar = GvAVn(PL_incgv);
3145 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3148 namesv = NEWSV(806, 0);
3149 for (i = 0; i <= AvFILL(ar); i++) {
3150 SV *dirsv = *av_fetch(ar, i, TRUE);
3156 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3157 && !sv_isobject(loader))
3159 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3162 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3163 PTR2UV(SvANY(loader)), name);
3164 tryname = SvPVX(namesv);
3175 if (sv_isobject(loader))
3176 count = call_method("INC", G_ARRAY);
3178 count = call_sv(loader, G_ARRAY);
3188 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3192 if (SvTYPE(arg) == SVt_PVGV) {
3193 IO *io = GvIO((GV *)arg);
3198 tryrsfp = IoIFP(io);
3199 if (IoTYPE(io) == IoTYPE_PIPE) {
3200 /* reading from a child process doesn't
3201 nest -- when returning from reading
3202 the inner module, the outer one is
3203 unreadable (closed?) I've tried to
3204 save the gv to manage the lifespan of
3205 the pipe, but this didn't help. XXX */
3206 filter_child_proc = (GV *)arg;
3207 (void)SvREFCNT_inc(filter_child_proc);
3210 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3211 PerlIO_close(IoOFP(io));
3223 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3225 (void)SvREFCNT_inc(filter_sub);
3228 filter_state = SP[i];
3229 (void)SvREFCNT_inc(filter_state);
3233 tryrsfp = PerlIO_open("/dev/null",
3247 filter_has_file = 0;
3248 if (filter_child_proc) {
3249 SvREFCNT_dec(filter_child_proc);
3250 filter_child_proc = 0;
3253 SvREFCNT_dec(filter_state);
3257 SvREFCNT_dec(filter_sub);
3262 char *dir = SvPVx(dirsv, n_a);
3263 #ifdef MACOS_TRADITIONAL
3265 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3269 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3271 sv_setpv(namesv, unixdir);
3272 sv_catpv(namesv, unixname);
3274 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3277 TAINT_PROPER("require");
3278 tryname = SvPVX(namesv);
3279 #ifdef MACOS_TRADITIONAL
3281 /* Convert slashes in the name part, but not the directory part, to colons */
3283 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3287 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3289 if (tryname[0] == '.' && tryname[1] == '/')
3297 SAVECOPFILE_FREE(&PL_compiling);
3298 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3299 SvREFCNT_dec(namesv);
3301 if (PL_op->op_type == OP_REQUIRE) {
3302 char *msgstr = name;
3303 if (namesv) { /* did we lookup @INC? */
3304 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3305 SV *dirmsgsv = NEWSV(0, 0);
3306 AV *ar = GvAVn(PL_incgv);
3308 sv_catpvn(msg, " in @INC", 8);
3309 if (instr(SvPVX(msg), ".h "))
3310 sv_catpv(msg, " (change .h to .ph maybe?)");
3311 if (instr(SvPVX(msg), ".ph "))
3312 sv_catpv(msg, " (did you run h2ph?)");
3313 sv_catpv(msg, " (@INC contains:");
3314 for (i = 0; i <= AvFILL(ar); i++) {
3315 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3316 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3317 sv_catsv(msg, dirmsgsv);
3319 sv_catpvn(msg, ")", 1);
3320 SvREFCNT_dec(dirmsgsv);
3321 msgstr = SvPV_nolen(msg);
3323 DIE(aTHX_ "Can't locate %s", msgstr);
3329 SETERRNO(0, SS$_NORMAL);
3331 /* Assume success here to prevent recursive requirement. */
3332 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3333 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3337 lex_start(sv_2mortal(newSVpvn("",0)));
3338 SAVEGENERICSV(PL_rsfp_filters);
3339 PL_rsfp_filters = Nullav;
3344 SAVESPTR(PL_compiling.cop_warnings);
3345 if (PL_dowarn & G_WARN_ALL_ON)
3346 PL_compiling.cop_warnings = pWARN_ALL ;
3347 else if (PL_dowarn & G_WARN_ALL_OFF)
3348 PL_compiling.cop_warnings = pWARN_NONE ;
3350 PL_compiling.cop_warnings = pWARN_STD ;
3351 SAVESPTR(PL_compiling.cop_io);
3352 PL_compiling.cop_io = Nullsv;
3354 if (filter_sub || filter_child_proc) {
3355 SV *datasv = filter_add(run_user_filter, Nullsv);
3356 IoLINES(datasv) = filter_has_file;
3357 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3358 IoTOP_GV(datasv) = (GV *)filter_state;
3359 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3362 /* switch to eval mode */
3363 push_return(PL_op->op_next);
3364 PUSHBLOCK(cx, CXt_EVAL, SP);
3365 PUSHEVAL(cx, name, Nullgv);
3367 SAVECOPLINE(&PL_compiling);
3368 CopLINE_set(&PL_compiling, 0);
3371 #ifdef USE_5005THREADS
3372 MUTEX_LOCK(&PL_eval_mutex);
3373 if (PL_eval_owner && PL_eval_owner != thr)
3374 while (PL_eval_owner)
3375 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3376 PL_eval_owner = thr;
3377 MUTEX_UNLOCK(&PL_eval_mutex);
3378 #endif /* USE_5005THREADS */
3379 return DOCATCH(doeval(gimme, NULL));
3384 return pp_require();
3390 register PERL_CONTEXT *cx;
3392 I32 gimme = GIMME_V, was = PL_sub_generation;
3393 char tbuf[TYPE_DIGITS(long) + 12];
3394 char *tmpbuf = tbuf;
3399 if (!SvPV(sv,len) || !len)
3401 TAINT_PROPER("eval");
3407 /* switch to eval mode */
3409 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3410 SV *sv = sv_newmortal();
3411 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3412 (unsigned long)++PL_evalseq,
3413 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3417 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3418 SAVECOPFILE_FREE(&PL_compiling);
3419 CopFILE_set(&PL_compiling, tmpbuf+2);
3420 SAVECOPLINE(&PL_compiling);
3421 CopLINE_set(&PL_compiling, 1);
3422 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3423 deleting the eval's FILEGV from the stash before gv_check() runs
3424 (i.e. before run-time proper). To work around the coredump that
3425 ensues, we always turn GvMULTI_on for any globals that were
3426 introduced within evals. See force_ident(). GSAR 96-10-12 */
3427 safestr = savepv(tmpbuf);
3428 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3430 PL_hints = PL_op->op_targ;
3431 SAVESPTR(PL_compiling.cop_warnings);
3432 if (specialWARN(PL_curcop->cop_warnings))
3433 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3435 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3436 SAVEFREESV(PL_compiling.cop_warnings);
3438 SAVESPTR(PL_compiling.cop_io);
3439 if (specialCopIO(PL_curcop->cop_io))
3440 PL_compiling.cop_io = PL_curcop->cop_io;
3442 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3443 SAVEFREESV(PL_compiling.cop_io);
3446 push_return(PL_op->op_next);
3447 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3448 PUSHEVAL(cx, 0, Nullgv);
3450 /* prepare to compile string */
3452 if (PERLDB_LINE && PL_curstash != PL_debstash)
3453 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3455 #ifdef USE_5005THREADS
3456 MUTEX_LOCK(&PL_eval_mutex);
3457 if (PL_eval_owner && PL_eval_owner != thr)
3458 while (PL_eval_owner)
3459 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3460 PL_eval_owner = thr;
3461 MUTEX_UNLOCK(&PL_eval_mutex);
3462 #endif /* USE_5005THREADS */
3463 ret = doeval(gimme, NULL);
3464 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3465 && ret != PL_op->op_next) { /* Successive compilation. */
3466 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3468 return DOCATCH(ret);
3478 register PERL_CONTEXT *cx;
3480 U8 save_flags = PL_op -> op_flags;
3485 retop = pop_return();
3488 if (gimme == G_VOID)
3490 else if (gimme == G_SCALAR) {
3493 if (SvFLAGS(TOPs) & SVs_TEMP)
3496 *MARK = sv_mortalcopy(TOPs);
3500 *MARK = &PL_sv_undef;
3505 /* in case LEAVE wipes old return values */
3506 for (mark = newsp + 1; mark <= SP; mark++) {
3507 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3508 *mark = sv_mortalcopy(*mark);
3509 TAINT_NOT; /* Each item is independent */
3513 PL_curpm = newpm; /* Don't pop $1 et al till now */
3516 assert(CvDEPTH(PL_compcv) == 1);
3518 CvDEPTH(PL_compcv) = 0;
3521 if (optype == OP_REQUIRE &&
3522 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3524 /* Unassume the success we assumed earlier. */
3525 SV *nsv = cx->blk_eval.old_namesv;
3526 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3527 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3528 /* die_where() did LEAVE, or we won't be here */
3532 if (!(save_flags & OPf_SPECIAL))
3542 register PERL_CONTEXT *cx;
3543 I32 gimme = GIMME_V;
3548 push_return(cLOGOP->op_other->op_next);
3549 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3552 PL_in_eval = EVAL_INEVAL;
3555 return DOCATCH(PL_op->op_next);
3565 register PERL_CONTEXT *cx;
3573 if (gimme == G_VOID)
3575 else if (gimme == G_SCALAR) {
3578 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3581 *MARK = sv_mortalcopy(TOPs);
3585 *MARK = &PL_sv_undef;
3590 /* in case LEAVE wipes old return values */
3591 for (mark = newsp + 1; mark <= SP; mark++) {
3592 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3593 *mark = sv_mortalcopy(*mark);
3594 TAINT_NOT; /* Each item is independent */
3598 PL_curpm = newpm; /* Don't pop $1 et al till now */
3606 S_doparseform(pTHX_ SV *sv)
3609 register char *s = SvPV_force(sv, len);
3610 register char *send = s + len;
3611 register char *base = Nullch;
3612 register I32 skipspaces = 0;
3613 bool noblank = FALSE;
3614 bool repeat = FALSE;
3615 bool postspace = FALSE;
3623 Perl_croak(aTHX_ "Null picture in formline");
3625 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3630 *fpc++ = FF_LINEMARK;
3631 noblank = repeat = FALSE;
3649 case ' ': case '\t':
3660 *fpc++ = FF_LITERAL;
3668 *fpc++ = skipspaces;
3672 *fpc++ = FF_NEWLINE;
3676 arg = fpc - linepc + 1;
3683 *fpc++ = FF_LINEMARK;
3684 noblank = repeat = FALSE;
3693 ischop = s[-1] == '^';
3699 arg = (s - base) - 1;
3701 *fpc++ = FF_LITERAL;
3710 *fpc++ = FF_LINEGLOB;
3712 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3713 arg = ischop ? 512 : 0;
3723 arg |= 256 + (s - f);
3725 *fpc++ = s - base; /* fieldsize for FETCH */
3726 *fpc++ = FF_DECIMAL;
3729 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3730 arg = ischop ? 512 : 0;
3732 s++; /* skip the '0' first */
3741 arg |= 256 + (s - f);
3743 *fpc++ = s - base; /* fieldsize for FETCH */
3744 *fpc++ = FF_0DECIMAL;
3749 bool ismore = FALSE;
3752 while (*++s == '>') ;
3753 prespace = FF_SPACE;
3755 else if (*s == '|') {
3756 while (*++s == '|') ;
3757 prespace = FF_HALFSPACE;
3762 while (*++s == '<') ;
3765 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3769 *fpc++ = s - base; /* fieldsize for FETCH */
3771 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3789 { /* need to jump to the next word */
3791 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3792 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3793 s = SvPVX(sv) + SvCUR(sv) + z;
3795 Copy(fops, s, arg, U16);
3797 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3802 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3804 * The original code was written in conjunction with BSD Computer Software
3805 * Research Group at University of California, Berkeley.
3807 * See also: "Optimistic Merge Sort" (SODA '92)
3809 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3811 * The code can be distributed under the same terms as Perl itself.
3816 #include <sys/types.h>
3821 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3822 #define Safefree(VAR) free(VAR)
3823 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3824 #endif /* TESTHARNESS */
3826 typedef char * aptr; /* pointer for arithmetic on sizes */
3827 typedef SV * gptr; /* pointers in our lists */
3829 /* Binary merge internal sort, with a few special mods
3830 ** for the special perl environment it now finds itself in.
3832 ** Things that were once options have been hotwired
3833 ** to values suitable for this use. In particular, we'll always
3834 ** initialize looking for natural runs, we'll always produce stable
3835 ** output, and we'll always do Peter McIlroy's binary merge.
3838 /* Pointer types for arithmetic and storage and convenience casts */
3840 #define APTR(P) ((aptr)(P))
3841 #define GPTP(P) ((gptr *)(P))
3842 #define GPPP(P) ((gptr **)(P))
3845 /* byte offset from pointer P to (larger) pointer Q */
3846 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3848 #define PSIZE sizeof(gptr)
3850 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3853 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3854 #define PNBYTE(N) ((N) << (PSHIFT))
3855 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3857 /* Leave optimization to compiler */
3858 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3859 #define PNBYTE(N) ((N) * (PSIZE))
3860 #define PINDEX(P, N) (GPTP(P) + (N))
3863 /* Pointer into other corresponding to pointer into this */
3864 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3866 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3869 /* Runs are identified by a pointer in the auxilliary list.
3870 ** The pointer is at the start of the list,
3871 ** and it points to the start of the next list.
3872 ** NEXT is used as an lvalue, too.
3875 #define NEXT(P) (*GPPP(P))
3878 /* PTHRESH is the minimum number of pairs with the same sense to justify
3879 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3880 ** not just elements, so PTHRESH == 8 means a run of 16.
3885 /* RTHRESH is the number of elements in a run that must compare low
3886 ** to the low element from the opposing run before we justify
3887 ** doing a binary rampup instead of single stepping.
3888 ** In random input, N in a row low should only happen with
3889 ** probability 2^(1-N), so we can risk that we are dealing
3890 ** with orderly input without paying much when we aren't.
3897 ** Overview of algorithm and variables.
3898 ** The array of elements at list1 will be organized into runs of length 2,
3899 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3900 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3902 ** Unless otherwise specified, pair pointers address the first of two elements.
3904 ** b and b+1 are a pair that compare with sense ``sense''.
3905 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3907 ** p2 parallels b in the list2 array, where runs are defined by
3910 ** t represents the ``top'' of the adjacent pairs that might extend
3911 ** the run beginning at b. Usually, t addresses a pair
3912 ** that compares with opposite sense from (b,b+1).
3913 ** However, it may also address a singleton element at the end of list1,
3914 ** or it may be equal to ``last'', the first element beyond list1.
3916 ** r addresses the Nth pair following b. If this would be beyond t,
3917 ** we back it off to t. Only when r is less than t do we consider the
3918 ** run long enough to consider checking.
3920 ** q addresses a pair such that the pairs at b through q already form a run.
3921 ** Often, q will equal b, indicating we only are sure of the pair itself.
3922 ** However, a search on the previous cycle may have revealed a longer run,
3923 ** so q may be greater than b.
3925 ** p is used to work back from a candidate r, trying to reach q,
3926 ** which would mean b through r would be a run. If we discover such a run,
3927 ** we start q at r and try to push it further towards t.
3928 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3929 ** In any event, after the check (if any), we have two main cases.
3931 ** 1) Short run. b <= q < p <= r <= t.
3932 ** b through q is a run (perhaps trivial)
3933 ** q through p are uninteresting pairs
3934 ** p through r is a run
3936 ** 2) Long run. b < r <= q < t.
3937 ** b through q is a run (of length >= 2 * PTHRESH)
3939 ** Note that degenerate cases are not only possible, but likely.
3940 ** For example, if the pair following b compares with opposite sense,
3941 ** then b == q < p == r == t.
3946 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3949 register gptr *b, *p, *q, *t, *p2;
3950 register gptr c, *last, *r;
3954 last = PINDEX(b, nmemb);
3955 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3956 for (p2 = list2; b < last; ) {
3957 /* We just started, or just reversed sense.
3958 ** Set t at end of pairs with the prevailing sense.
3960 for (p = b+2, t = p; ++p < last; t = ++p) {
3961 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3964 /* Having laid out the playing field, look for long runs */
3966 p = r = b + (2 * PTHRESH);
3967 if (r >= t) p = r = t; /* too short to care about */
3969 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3972 /* b through r is a (long) run.
3973 ** Extend it as far as possible.
3976 while (((p += 2) < t) &&
3977 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3978 r = p = q + 2; /* no simple pairs, no after-run */
3981 if (q > b) { /* run of greater than 2 at b */
3984 /* pick up singleton, if possible */
3986 ((t + 1) == last) &&
3987 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3988 savep = r = p = q = last;
3989 p2 = NEXT(p2) = p2 + (p - b);
3990 if (sense) while (b < --p) {
3997 while (q < p) { /* simple pairs */
3998 p2 = NEXT(p2) = p2 + 2;
4005 if (((b = p) == t) && ((t+1) == last)) {
4017 /* Overview of bmerge variables:
4019 ** list1 and list2 address the main and auxiliary arrays.
4020 ** They swap identities after each merge pass.
4021 ** Base points to the original list1, so we can tell if
4022 ** the pointers ended up where they belonged (or must be copied).
4024 ** When we are merging two lists, f1 and f2 are the next elements
4025 ** on the respective lists. l1 and l2 mark the end of the lists.
4026 ** tp2 is the current location in the merged list.
4028 ** p1 records where f1 started.
4029 ** After the merge, a new descriptor is built there.
4031 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4032 ** It is used to identify and delimit the runs.
4034 ** In the heat of determining where q, the greater of the f1/f2 elements,
4035 ** belongs in the other list, b, t and p, represent bottom, top and probe
4036 ** locations, respectively, in the other list.
4037 ** They make convenient temporary pointers in other places.
4041 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4045 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4046 gptr *aux, *list2, *p2, *last;
4050 if (nmemb <= 1) return; /* sorted trivially */
4051 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4053 dynprep(aTHX_ list1, list2, nmemb, cmp);
4054 last = PINDEX(list2, nmemb);
4055 while (NEXT(list2) != last) {
4056 /* More than one run remains. Do some merging to reduce runs. */
4058 for (tp2 = p2 = list2; p2 != last;) {
4059 /* The new first run begins where the old second list ended.
4060 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4064 f2 = l1 = POTHER(t, list2, list1);
4065 if (t != last) t = NEXT(t);
4066 l2 = POTHER(t, list2, list1);
4068 while (f1 < l1 && f2 < l2) {
4069 /* If head 1 is larger than head 2, find ALL the elements
4070 ** in list 2 strictly less than head1, write them all,
4071 ** then head 1. Then compare the new heads, and repeat,
4072 ** until one or both lists are exhausted.
4074 ** In all comparisons (after establishing
4075 ** which head to merge) the item to merge
4076 ** (at pointer q) is the first operand of
4077 ** the comparison. When we want to know
4078 ** if ``q is strictly less than the other'',
4080 ** cmp(q, other) < 0
4081 ** because stability demands that we treat equality
4082 ** as high when q comes from l2, and as low when
4083 ** q was from l1. So we ask the question by doing
4084 ** cmp(q, other) <= sense
4085 ** and make sense == 0 when equality should look low,
4086 ** and -1 when equality should look high.
4090 if (cmp(aTHX_ *f1, *f2) <= 0) {
4091 q = f2; b = f1; t = l1;
4094 q = f1; b = f2; t = l2;
4101 ** Leave t at something strictly
4102 ** greater than q (or at the end of the list),
4103 ** and b at something strictly less than q.
4105 for (i = 1, run = 0 ;;) {
4106 if ((p = PINDEX(b, i)) >= t) {
4108 if (((p = PINDEX(t, -1)) > b) &&
4109 (cmp(aTHX_ *q, *p) <= sense))
4113 } else if (cmp(aTHX_ *q, *p) <= sense) {
4117 if (++run >= RTHRESH) i += i;
4121 /* q is known to follow b and must be inserted before t.
4122 ** Increment b, so the range of possibilities is [b,t).
4123 ** Round binary split down, to favor early appearance.
4124 ** Adjust b and t until q belongs just before t.
4129 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4130 if (cmp(aTHX_ *q, *p) <= sense) {
4136 /* Copy all the strictly low elements */
4139 FROMTOUPTO(f2, tp2, t);
4142 FROMTOUPTO(f1, tp2, t);
4148 /* Run out remaining list */
4150 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4151 } else FROMTOUPTO(f1, tp2, l1);
4152 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4157 last = PINDEX(list2, nmemb);
4159 if (base == list2) {
4160 last = PINDEX(list1, nmemb);
4161 FROMTOUPTO(list1, list2, last);
4176 sortcv(pTHXo_ SV *a, SV *b)
4178 I32 oldsaveix = PL_savestack_ix;
4179 I32 oldscopeix = PL_scopestack_ix;
4181 GvSV(PL_firstgv) = a;
4182 GvSV(PL_secondgv) = b;
4183 PL_stack_sp = PL_stack_base;
4186 if (PL_stack_sp != PL_stack_base + 1)
4187 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4188 if (!SvNIOKp(*PL_stack_sp))
4189 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4190 result = SvIV(*PL_stack_sp);
4191 while (PL_scopestack_ix > oldscopeix) {
4194 leave_scope(oldsaveix);
4199 sortcv_stacked(pTHXo_ SV *a, SV *b)
4201 I32 oldsaveix = PL_savestack_ix;
4202 I32 oldscopeix = PL_scopestack_ix;
4206 #ifdef USE_5005THREADS
4207 av = (AV*)PL_curpad[0];
4209 av = GvAV(PL_defgv);
4212 if (AvMAX(av) < 1) {
4213 SV** ary = AvALLOC(av);
4214 if (AvARRAY(av) != ary) {
4215 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4216 SvPVX(av) = (char*)ary;
4218 if (AvMAX(av) < 1) {
4221 SvPVX(av) = (char*)ary;
4228 PL_stack_sp = PL_stack_base;
4231 if (PL_stack_sp != PL_stack_base + 1)
4232 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4233 if (!SvNIOKp(*PL_stack_sp))
4234 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4235 result = SvIV(*PL_stack_sp);
4236 while (PL_scopestack_ix > oldscopeix) {
4239 leave_scope(oldsaveix);
4244 sortcv_xsub(pTHXo_ SV *a, SV *b)
4247 I32 oldsaveix = PL_savestack_ix;
4248 I32 oldscopeix = PL_scopestack_ix;
4250 CV *cv=(CV*)PL_sortcop;
4258 (void)(*CvXSUB(cv))(aTHXo_ cv);
4259 if (PL_stack_sp != PL_stack_base + 1)
4260 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4261 if (!SvNIOKp(*PL_stack_sp))
4262 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4263 result = SvIV(*PL_stack_sp);
4264 while (PL_scopestack_ix > oldscopeix) {
4267 leave_scope(oldsaveix);
4273 sv_ncmp(pTHXo_ SV *a, SV *b)
4277 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4281 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4285 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4287 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4289 if (PL_amagic_generation) { \
4290 if (SvAMAGIC(left)||SvAMAGIC(right))\
4291 *svp = amagic_call(left, \
4299 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4302 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4307 I32 i = SvIVX(tmpsv);
4317 return sv_ncmp(aTHXo_ a, b);
4321 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4324 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4329 I32 i = SvIVX(tmpsv);
4339 return sv_i_ncmp(aTHXo_ a, b);
4343 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4346 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4351 I32 i = SvIVX(tmpsv);
4361 return sv_cmp(str1, str2);
4365 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4368 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4373 I32 i = SvIVX(tmpsv);
4383 return sv_cmp_locale(str1, str2);
4387 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4389 SV *datasv = FILTER_DATA(idx);
4390 int filter_has_file = IoLINES(datasv);
4391 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4392 SV *filter_state = (SV *)IoTOP_GV(datasv);
4393 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4396 /* I was having segfault trouble under Linux 2.2.5 after a
4397 parse error occured. (Had to hack around it with a test
4398 for PL_error_count == 0.) Solaris doesn't segfault --
4399 not sure where the trouble is yet. XXX */
4401 if (filter_has_file) {
4402 len = FILTER_READ(idx+1, buf_sv, maxlen);
4405 if (filter_sub && len >= 0) {
4416 PUSHs(sv_2mortal(newSViv(maxlen)));
4418 PUSHs(filter_state);
4421 count = call_sv(filter_sub, G_SCALAR);
4437 IoLINES(datasv) = 0;
4438 if (filter_child_proc) {
4439 SvREFCNT_dec(filter_child_proc);
4440 IoFMT_GV(datasv) = Nullgv;
4443 SvREFCNT_dec(filter_state);
4444 IoTOP_GV(datasv) = Nullgv;
4447 SvREFCNT_dec(filter_sub);
4448 IoBOTTOM_GV(datasv) = Nullgv;
4450 filter_del(run_user_filter);
4459 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4461 return sv_cmp_locale(str1, str2);
4465 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4467 return sv_cmp(str1, str2);
4470 #endif /* PERL_OBJECT */