3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 sortcv(pTHX_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHX_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHX_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHX_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHX_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHX_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHX_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHX_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHX_ SV *a, SV *b);
38 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
40 #define sv_cmp_static Perl_sv_cmp
41 #define sv_cmp_locale_static Perl_sv_cmp_locale
49 cxix = dopoptosub(cxstack_ix);
53 switch (cxstack[cxix].blk_gimme) {
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
79 register PMOP *pm = (PMOP*)cLOGOP->op_other;
83 MAGIC *mg = Null(MAGIC*);
87 /* prevent recompiling under /o and ithreads. */
88 #if defined(USE_ITHREADS) || defined(USE_5005THREADS)
89 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
94 SV *sv = SvRV(tmpstr);
96 mg = mg_find(sv, PERL_MAGIC_qr);
99 regexp *re = (regexp *)mg->mg_obj;
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, ReREFCNT_inc(re));
104 t = SvPV(tmpstr, len);
106 /* Check against the last compiled regexp. */
107 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
108 PM_GETRE(pm)->prelen != len ||
109 memNE(PM_GETRE(pm)->precomp, t, len))
112 ReREFCNT_dec(PM_GETRE(pm));
113 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
115 if (PL_op->op_flags & OPf_SPECIAL)
116 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
118 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
120 pm->op_pmdynflags |= PMdf_DYN_UTF8;
122 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
123 if (pm->op_pmdynflags & PMdf_UTF8)
124 t = (char*)bytes_to_utf8((U8*)t, &len);
126 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
127 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
129 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
130 inside tie/overload accessors. */
134 #ifndef INCOMPLETE_TAINTS
137 pm->op_pmdynflags |= PMdf_TAINTED;
139 pm->op_pmdynflags &= ~PMdf_TAINTED;
143 if (!PM_GETRE(pm)->prelen && PL_curpm)
145 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
146 pm->op_pmflags |= PMf_WHITE;
148 pm->op_pmflags &= ~PMf_WHITE;
150 /* XXX runtime compiled output needs to move to the pad */
151 if (pm->op_pmflags & PMf_KEEP) {
152 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
153 #if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
154 /* XXX can't change the optree at runtime either */
155 cLOGOP->op_first->op_next = PL_op->op_next;
164 register PMOP *pm = (PMOP*) cLOGOP->op_other;
165 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
166 register SV *dstr = cx->sb_dstr;
167 register char *s = cx->sb_s;
168 register char *m = cx->sb_m;
169 char *orig = cx->sb_orig;
170 register REGEXP *rx = cx->sb_rx;
172 rxres_restore(&cx->sb_rxres, rx);
174 if (cx->sb_iters++) {
175 I32 saviters = cx->sb_iters;
176 if (cx->sb_iters > cx->sb_maxiters)
177 DIE(aTHX_ "Substitution loop");
179 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
180 cx->sb_rxtainted |= 2;
181 sv_catsv(dstr, POPs);
184 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
185 s == m, cx->sb_targ, NULL,
186 ((cx->sb_rflags & REXEC_COPY_STR)
187 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
188 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
190 SV *targ = cx->sb_targ;
192 sv_catpvn(dstr, s, cx->sb_strend - s);
193 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
195 (void)SvOOK_off(targ);
196 Safefree(SvPVX(targ));
197 SvPVX(targ) = SvPVX(dstr);
198 SvCUR_set(targ, SvCUR(dstr));
199 SvLEN_set(targ, SvLEN(dstr));
205 TAINT_IF(cx->sb_rxtainted & 1);
206 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
208 (void)SvPOK_only_UTF8(targ);
209 TAINT_IF(cx->sb_rxtainted);
213 LEAVE_SCOPE(cx->sb_oldsave);
215 RETURNOP(pm->op_next);
217 cx->sb_iters = saviters;
219 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
222 cx->sb_orig = orig = rx->subbeg;
224 cx->sb_strend = s + (cx->sb_strend - m);
226 cx->sb_m = m = rx->startp[0] + orig;
228 sv_catpvn(dstr, s, m-s);
229 cx->sb_s = rx->endp[0] + orig;
230 { /* Update the pos() information. */
231 SV *sv = cx->sb_targ;
234 if (SvTYPE(sv) < SVt_PVMG)
235 (void)SvUPGRADE(sv, SVt_PVMG);
236 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
237 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
238 mg = mg_find(sv, PERL_MAGIC_regex_global);
245 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
246 rxres_save(&cx->sb_rxres, rx);
247 RETURNOP(pm->op_pmreplstart);
251 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
256 if (!p || p[1] < rx->nparens) {
257 i = 6 + rx->nparens * 2;
265 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
266 RX_MATCH_COPIED_off(rx);
270 *p++ = PTR2UV(rx->subbeg);
271 *p++ = (UV)rx->sublen;
272 for (i = 0; i <= rx->nparens; ++i) {
273 *p++ = (UV)rx->startp[i];
274 *p++ = (UV)rx->endp[i];
279 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
284 if (RX_MATCH_COPIED(rx))
285 Safefree(rx->subbeg);
286 RX_MATCH_COPIED_set(rx, *p);
291 rx->subbeg = INT2PTR(char*,*p++);
292 rx->sublen = (I32)(*p++);
293 for (i = 0; i <= rx->nparens; ++i) {
294 rx->startp[i] = (I32)(*p++);
295 rx->endp[i] = (I32)(*p++);
300 Perl_rxres_free(pTHX_ void **rsp)
305 Safefree(INT2PTR(char*,*p));
313 dSP; dMARK; dORIGMARK;
314 register SV *tmpForm = *++MARK;
321 register SV *sv = Nullsv;
326 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
327 char *chophere = Nullch;
328 char *linemark = Nullch;
330 bool gotsome = FALSE;
332 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
333 bool item_is_utf = FALSE;
335 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
336 if (SvREADONLY(tmpForm)) {
337 SvREADONLY_off(tmpForm);
338 doparseform(tmpForm);
339 SvREADONLY_on(tmpForm);
342 doparseform(tmpForm);
345 SvPV_force(PL_formtarget, len);
346 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
348 f = SvPV(tmpForm, len);
349 /* need to jump to the next word */
350 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
359 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
360 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
361 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
362 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
363 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
365 case FF_CHECKNL: name = "CHECKNL"; break;
366 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
367 case FF_SPACE: name = "SPACE"; break;
368 case FF_HALFSPACE: name = "HALFSPACE"; break;
369 case FF_ITEM: name = "ITEM"; break;
370 case FF_CHOP: name = "CHOP"; break;
371 case FF_LINEGLOB: name = "LINEGLOB"; break;
372 case FF_NEWLINE: name = "NEWLINE"; break;
373 case FF_MORE: name = "MORE"; break;
374 case FF_LINEMARK: name = "LINEMARK"; break;
375 case FF_END: name = "END"; break;
376 case FF_0DECIMAL: name = "0DECIMAL"; break;
379 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
381 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
409 if (ckWARN(WARN_SYNTAX))
410 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
415 item = s = SvPV(sv, len);
418 itemsize = sv_len_utf8(sv);
419 if (itemsize != len) {
421 if (itemsize > fieldsize) {
422 itemsize = fieldsize;
423 itembytes = itemsize;
424 sv_pos_u2b(sv, &itembytes, 0);
428 send = chophere = s + itembytes;
438 sv_pos_b2u(sv, &itemsize);
443 if (itemsize > fieldsize)
444 itemsize = fieldsize;
445 send = chophere = s + itemsize;
457 item = s = SvPV(sv, len);
460 itemsize = sv_len_utf8(sv);
461 if (itemsize != len) {
463 if (itemsize <= fieldsize) {
464 send = chophere = s + itemsize;
475 itemsize = fieldsize;
476 itembytes = itemsize;
477 sv_pos_u2b(sv, &itembytes, 0);
478 send = chophere = s + itembytes;
479 while (s < send || (s == send && isSPACE(*s))) {
489 if (strchr(PL_chopset, *s))
494 itemsize = chophere - item;
495 sv_pos_b2u(sv, &itemsize);
502 if (itemsize <= fieldsize) {
503 send = chophere = s + itemsize;
514 itemsize = fieldsize;
515 send = chophere = s + itemsize;
516 while (s < send || (s == send && isSPACE(*s))) {
526 if (strchr(PL_chopset, *s))
531 itemsize = chophere - item;
536 arg = fieldsize - itemsize;
545 arg = fieldsize - itemsize;
559 if (UTF8_IS_CONTINUED(*s)) {
560 STRLEN skip = UTF8SKIP(s);
577 if ( !((*t++ = *s++) & ~31) )
585 int ch = *t++ = *s++;
588 if ( !((*t++ = *s++) & ~31) )
597 while (*s && isSPACE(*s))
604 item = s = SvPV(sv, len);
606 item_is_utf = FALSE; /* XXX is this correct? */
618 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
619 sv_catpvn(PL_formtarget, item, itemsize);
620 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
621 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
626 /* If the field is marked with ^ and the value is undefined,
629 if ((arg & 512) && !SvOK(sv)) {
637 /* Formats aren't yet marked for locales, so assume "yes". */
639 STORE_NUMERIC_STANDARD_SET_LOCAL();
640 #if defined(USE_LONG_DOUBLE)
642 sprintf(t, "%#*.*" PERL_PRIfldbl,
643 (int) fieldsize, (int) arg & 255, value);
645 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
650 (int) fieldsize, (int) arg & 255, value);
653 (int) fieldsize, value);
656 RESTORE_NUMERIC_STANDARD();
662 /* If the field is marked with ^ and the value is undefined,
665 if ((arg & 512) && !SvOK(sv)) {
673 /* Formats aren't yet marked for locales, so assume "yes". */
675 STORE_NUMERIC_STANDARD_SET_LOCAL();
676 #if defined(USE_LONG_DOUBLE)
678 sprintf(t, "%#0*.*" PERL_PRIfldbl,
679 (int) fieldsize, (int) arg & 255, value);
680 /* is this legal? I don't have long doubles */
682 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
686 sprintf(t, "%#0*.*f",
687 (int) fieldsize, (int) arg & 255, value);
690 (int) fieldsize, value);
693 RESTORE_NUMERIC_STANDARD();
700 while (t-- > linemark && *t == ' ') ;
708 if (arg) { /* repeat until fields exhausted? */
710 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
711 lines += FmLINES(PL_formtarget);
714 if (strnEQ(linemark, linemark - arg, arg))
715 DIE(aTHX_ "Runaway format");
717 FmLINES(PL_formtarget) = lines;
719 RETURNOP(cLISTOP->op_first);
732 while (*s && isSPACE(*s) && s < send)
736 arg = fieldsize - itemsize;
743 if (strnEQ(s," ",3)) {
744 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
755 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
756 FmLINES(PL_formtarget) += lines;
768 if (PL_stack_base + *PL_markstack_ptr == SP) {
770 if (GIMME_V == G_SCALAR)
771 XPUSHs(sv_2mortal(newSViv(0)));
772 RETURNOP(PL_op->op_next->op_next);
774 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
775 pp_pushmark(); /* push dst */
776 pp_pushmark(); /* push src */
777 ENTER; /* enter outer scope */
780 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
782 ENTER; /* enter inner scope */
785 src = PL_stack_base[*PL_markstack_ptr];
790 if (PL_op->op_type == OP_MAPSTART)
791 pp_pushmark(); /* push top */
792 return ((LOGOP*)PL_op->op_next)->op_other;
797 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
803 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
809 /* first, move source pointer to the next item in the source list */
810 ++PL_markstack_ptr[-1];
812 /* if there are new items, push them into the destination list */
814 /* might need to make room back there first */
815 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
816 /* XXX this implementation is very pessimal because the stack
817 * is repeatedly extended for every set of items. Is possible
818 * to do this without any stack extension or copying at all
819 * by maintaining a separate list over which the map iterates
820 * (like foreach does). --gsar */
822 /* everything in the stack after the destination list moves
823 * towards the end the stack by the amount of room needed */
824 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
826 /* items to shift up (accounting for the moved source pointer) */
827 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
829 /* This optimization is by Ben Tilly and it does
830 * things differently from what Sarathy (gsar)
831 * is describing. The downside of this optimization is
832 * that leaves "holes" (uninitialized and hopefully unused areas)
833 * to the Perl stack, but on the other hand this
834 * shouldn't be a problem. If Sarathy's idea gets
835 * implemented, this optimization should become
836 * irrelevant. --jhi */
838 shift = count; /* Avoid shifting too often --Ben Tilly */
843 PL_markstack_ptr[-1] += shift;
844 *PL_markstack_ptr += shift;
848 /* copy the new items down to the destination list */
849 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
851 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
853 LEAVE; /* exit inner scope */
856 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
859 (void)POPMARK; /* pop top */
860 LEAVE; /* exit outer scope */
861 (void)POPMARK; /* pop src */
862 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
863 (void)POPMARK; /* pop dst */
864 SP = PL_stack_base + POPMARK; /* pop original mark */
865 if (gimme == G_SCALAR) {
869 else if (gimme == G_ARRAY)
876 ENTER; /* enter inner scope */
879 /* set $_ to the new source item */
880 src = PL_stack_base[PL_markstack_ptr[-1]];
884 RETURNOP(cLOGOP->op_other);
890 dSP; dMARK; dORIGMARK;
892 SV **myorigmark = ORIGMARK;
898 OP* nextop = PL_op->op_next;
900 bool hasargs = FALSE;
903 if (gimme != G_ARRAY) {
909 SAVEVPTR(PL_sortcop);
910 if (PL_op->op_flags & OPf_STACKED) {
911 if (PL_op->op_flags & OPf_SPECIAL) {
912 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
913 kid = kUNOP->op_first; /* pass rv2gv */
914 kid = kUNOP->op_first; /* pass leave */
915 PL_sortcop = kid->op_next;
916 stash = CopSTASH(PL_curcop);
919 cv = sv_2cv(*++MARK, &stash, &gv, 0);
920 if (cv && SvPOK(cv)) {
922 char *proto = SvPV((SV*)cv, n_a);
923 if (proto && strEQ(proto, "$$")) {
927 if (!(cv && CvROOT(cv))) {
928 if (cv && CvXSUB(cv)) {
932 SV *tmpstr = sv_newmortal();
933 gv_efullname3(tmpstr, gv, Nullch);
934 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
938 DIE(aTHX_ "Undefined subroutine in sort");
943 PL_sortcop = (OP*)cv;
945 PL_sortcop = CvSTART(cv);
946 SAVEVPTR(CvROOT(cv)->op_ppaddr);
947 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
950 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
956 stash = CopSTASH(PL_curcop);
960 while (MARK < SP) { /* This may or may not shift down one here. */
962 if ((*up = *++MARK)) { /* Weed out nulls. */
964 if (!PL_sortcop && !SvPOK(*up)) {
969 (void)sv_2pv(*up, &n_a);
974 max = --up - myorigmark;
979 bool oldcatch = CATCH_GET;
985 PUSHSTACKi(PERLSI_SORT);
986 if (!hasargs && !is_xsub) {
987 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
988 SAVESPTR(PL_firstgv);
989 SAVESPTR(PL_secondgv);
990 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
991 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
992 PL_sortstash = stash;
994 #ifdef USE_5005THREADS
995 sv_lock((SV *)PL_firstgv);
996 sv_lock((SV *)PL_secondgv);
998 SAVESPTR(GvSV(PL_firstgv));
999 SAVESPTR(GvSV(PL_secondgv));
1002 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1003 if (!(PL_op->op_flags & OPf_SPECIAL)) {
1004 cx->cx_type = CXt_SUB;
1005 cx->blk_gimme = G_SCALAR;
1008 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1010 PL_sortcxix = cxstack_ix;
1012 if (hasargs && !is_xsub) {
1013 /* This is mostly copied from pp_entersub */
1014 AV *av = (AV*)PL_curpad[0];
1016 #ifndef USE_5005THREADS
1017 cx->blk_sub.savearray = GvAV(PL_defgv);
1018 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1019 #endif /* USE_5005THREADS */
1020 cx->blk_sub.oldcurpad = PL_curpad;
1021 cx->blk_sub.argarray = av;
1023 sortsv((myorigmark+1), max,
1024 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1026 POPBLOCK(cx,PL_curpm);
1027 PL_stack_sp = newsp;
1029 CATCH_SET(oldcatch);
1034 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1035 sortsv(ORIGMARK+1, max,
1036 (PL_op->op_private & OPpSORT_NUMERIC)
1037 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1038 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1039 : ( overloading ? amagic_ncmp : sv_ncmp))
1040 : ( IN_LOCALE_RUNTIME
1043 : sv_cmp_locale_static)
1044 : ( overloading ? amagic_cmp : sv_cmp_static)));
1045 if (PL_op->op_private & OPpSORT_REVERSE) {
1046 SV **p = ORIGMARK+1;
1047 SV **q = ORIGMARK+max;
1057 PL_stack_sp = ORIGMARK + max;
1065 if (GIMME == G_ARRAY)
1067 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1068 return cLOGOP->op_other;
1077 if (GIMME == G_ARRAY) {
1078 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1082 SV *targ = PAD_SV(PL_op->op_targ);
1085 if (PL_op->op_private & OPpFLIP_LINENUM) {
1087 flip = PL_last_in_gv
1088 && (gp_io = GvIO(PL_last_in_gv))
1089 && SvIV(sv) == (IV)IoLINES(gp_io);
1094 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1095 if (PL_op->op_flags & OPf_SPECIAL) {
1103 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1116 if (GIMME == G_ARRAY) {
1122 if (SvGMAGICAL(left))
1124 if (SvGMAGICAL(right))
1127 if (SvNIOKp(left) || !SvPOKp(left) ||
1128 SvNIOKp(right) || !SvPOKp(right) ||
1129 (looks_like_number(left) && *SvPVX(left) != '0' &&
1130 looks_like_number(right) && *SvPVX(right) != '0'))
1132 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1133 DIE(aTHX_ "Range iterator outside integer range");
1144 sv = sv_2mortal(newSViv(i++));
1149 SV *final = sv_mortalcopy(right);
1151 char *tmps = SvPV(final, len);
1153 sv = sv_mortalcopy(left);
1155 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1157 if (strEQ(SvPVX(sv),tmps))
1159 sv = sv_2mortal(newSVsv(sv));
1166 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1168 if ((PL_op->op_private & OPpFLIP_LINENUM)
1169 ? (GvIO(PL_last_in_gv)
1170 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1172 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1173 sv_catpv(targ, "E0");
1184 S_dopoptolabel(pTHX_ char *label)
1187 register PERL_CONTEXT *cx;
1189 for (i = cxstack_ix; i >= 0; i--) {
1191 switch (CxTYPE(cx)) {
1193 if (ckWARN(WARN_EXITING))
1194 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1198 if (ckWARN(WARN_EXITING))
1199 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1203 if (ckWARN(WARN_EXITING))
1204 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1208 if (ckWARN(WARN_EXITING))
1209 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1213 if (ckWARN(WARN_EXITING))
1214 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1218 if (!cx->blk_loop.label ||
1219 strNE(label, cx->blk_loop.label) ) {
1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1221 (long)i, cx->blk_loop.label));
1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1232 Perl_dowantarray(pTHX)
1234 I32 gimme = block_gimme();
1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1239 Perl_block_gimme(pTHX)
1243 cxix = dopoptosub(cxstack_ix);
1247 switch (cxstack[cxix].blk_gimme) {
1255 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1262 Perl_is_lvalue_sub(pTHX)
1266 cxix = dopoptosub(cxstack_ix);
1267 assert(cxix >= 0); /* We should only be called from inside subs */
1269 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1270 return cxstack[cxix].blk_sub.lval;
1276 S_dopoptosub(pTHX_ I32 startingblock)
1278 return dopoptosub_at(cxstack, startingblock);
1282 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1285 register PERL_CONTEXT *cx;
1286 for (i = startingblock; i >= 0; i--) {
1288 switch (CxTYPE(cx)) {
1294 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1302 S_dopoptoeval(pTHX_ I32 startingblock)
1305 register PERL_CONTEXT *cx;
1306 for (i = startingblock; i >= 0; i--) {
1308 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1323 register PERL_CONTEXT *cx;
1324 for (i = startingblock; i >= 0; i--) {
1326 switch (CxTYPE(cx)) {
1328 if (ckWARN(WARN_EXITING))
1329 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1333 if (ckWARN(WARN_EXITING))
1334 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1338 if (ckWARN(WARN_EXITING))
1339 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1343 if (ckWARN(WARN_EXITING))
1344 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1348 if (ckWARN(WARN_EXITING))
1349 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1353 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1361 Perl_dounwind(pTHX_ I32 cxix)
1363 register PERL_CONTEXT *cx;
1366 while (cxstack_ix > cxix) {
1368 cx = &cxstack[cxstack_ix];
1369 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1370 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1371 /* Note: we don't need to restore the base context info till the end. */
1372 switch (CxTYPE(cx)) {
1375 continue; /* not break */
1397 Perl_qerror(pTHX_ SV *err)
1400 sv_catsv(ERRSV, err);
1402 sv_catsv(PL_errors, err);
1404 Perl_warn(aTHX_ "%"SVf, err);
1409 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1414 register PERL_CONTEXT *cx;
1419 if (PL_in_eval & EVAL_KEEPERR) {
1420 static char prefix[] = "\t(in cleanup) ";
1425 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1428 if (*e != *message || strNE(e,message))
1432 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1433 sv_catpvn(err, prefix, sizeof(prefix)-1);
1434 sv_catpvn(err, message, msglen);
1435 if (ckWARN(WARN_MISC)) {
1436 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1437 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1442 sv_setpvn(ERRSV, message, msglen);
1446 message = SvPVx(ERRSV, msglen);
1448 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1449 && PL_curstackinfo->si_prev)
1458 if (cxix < cxstack_ix)
1461 POPBLOCK(cx,PL_curpm);
1462 if (CxTYPE(cx) != CXt_EVAL) {
1463 PerlIO_write(Perl_error_log, "panic: die ", 11);
1464 PerlIO_write(Perl_error_log, message, msglen);
1469 if (gimme == G_SCALAR)
1470 *++newsp = &PL_sv_undef;
1471 PL_stack_sp = newsp;
1475 /* LEAVE could clobber PL_curcop (see save_re_context())
1476 * XXX it might be better to find a way to avoid messing with
1477 * PL_curcop in save_re_context() instead, but this is a more
1478 * minimal fix --GSAR */
1479 PL_curcop = cx->blk_oldcop;
1481 if (optype == OP_REQUIRE) {
1482 char* msg = SvPVx(ERRSV, n_a);
1483 DIE(aTHX_ "%sCompilation failed in require",
1484 *msg ? msg : "Unknown error\n");
1486 return pop_return();
1490 message = SvPVx(ERRSV, msglen);
1493 /* SFIO can really mess with your errno */
1496 PerlIO *serr = Perl_error_log;
1498 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1499 (void)PerlIO_flush(serr);
1512 if (SvTRUE(left) != SvTRUE(right))
1524 RETURNOP(cLOGOP->op_other);
1533 RETURNOP(cLOGOP->op_other);
1539 register I32 cxix = dopoptosub(cxstack_ix);
1540 register PERL_CONTEXT *cx;
1541 register PERL_CONTEXT *ccstack = cxstack;
1542 PERL_SI *top_si = PL_curstackinfo;
1553 /* we may be in a higher stacklevel, so dig down deeper */
1554 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1555 top_si = top_si->si_prev;
1556 ccstack = top_si->si_cxstack;
1557 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1560 if (GIMME != G_ARRAY) {
1566 if (PL_DBsub && cxix >= 0 &&
1567 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1571 cxix = dopoptosub_at(ccstack, cxix - 1);
1574 cx = &ccstack[cxix];
1575 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1576 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1577 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1578 field below is defined for any cx. */
1579 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1580 cx = &ccstack[dbcxix];
1583 stashname = CopSTASHPV(cx->blk_oldcop);
1584 if (GIMME != G_ARRAY) {
1587 PUSHs(&PL_sv_undef);
1590 sv_setpv(TARG, stashname);
1599 PUSHs(&PL_sv_undef);
1601 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1602 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1603 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1606 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1607 /* So is ccstack[dbcxix]. */
1609 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1610 PUSHs(sv_2mortal(sv));
1611 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1614 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1615 PUSHs(sv_2mortal(newSViv(0)));
1617 gimme = (I32)cx->blk_gimme;
1618 if (gimme == G_VOID)
1619 PUSHs(&PL_sv_undef);
1621 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1622 if (CxTYPE(cx) == CXt_EVAL) {
1624 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1625 PUSHs(cx->blk_eval.cur_text);
1629 else if (cx->blk_eval.old_namesv) {
1630 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1633 /* eval BLOCK (try blocks have old_namesv == 0) */
1635 PUSHs(&PL_sv_undef);
1636 PUSHs(&PL_sv_undef);
1640 PUSHs(&PL_sv_undef);
1641 PUSHs(&PL_sv_undef);
1643 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1644 && CopSTASH_eq(PL_curcop, PL_debstash))
1646 AV *ary = cx->blk_sub.argarray;
1647 int off = AvARRAY(ary) - AvALLOC(ary);
1651 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1654 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1657 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1658 av_extend(PL_dbargs, AvFILLp(ary) + off);
1659 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1660 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1662 /* XXX only hints propagated via op_private are currently
1663 * visible (others are not easily accessible, since they
1664 * use the global PL_hints) */
1665 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1666 HINT_PRIVATE_MASK)));
1669 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1671 if (old_warnings == pWARN_NONE ||
1672 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1673 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1674 else if (old_warnings == pWARN_ALL ||
1675 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1676 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1678 mask = newSVsv(old_warnings);
1679 PUSHs(sv_2mortal(mask));
1694 sv_reset(tmps, CopSTASH(PL_curcop));
1706 PL_curcop = (COP*)PL_op;
1707 TAINT_NOT; /* Each statement is presumed innocent */
1708 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1711 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1715 register PERL_CONTEXT *cx;
1716 I32 gimme = G_ARRAY;
1723 DIE(aTHX_ "No DB::DB routine defined");
1725 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1726 /* don't do recursive DB::DB call */
1738 push_return(PL_op->op_next);
1739 PUSHBLOCK(cx, CXt_SUB, SP);
1742 (void)SvREFCNT_inc(cv);
1743 SAVEVPTR(PL_curpad);
1744 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1745 RETURNOP(CvSTART(cv));
1759 register PERL_CONTEXT *cx;
1760 I32 gimme = GIMME_V;
1762 U32 cxtype = CXt_LOOP;
1770 #ifdef USE_5005THREADS
1771 if (PL_op->op_flags & OPf_SPECIAL) {
1772 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1773 SAVEGENERICSV(*svp);
1777 #endif /* USE_5005THREADS */
1778 if (PL_op->op_targ) {
1779 #ifndef USE_ITHREADS
1780 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1783 SAVEPADSV(PL_op->op_targ);
1784 iterdata = INT2PTR(void*, PL_op->op_targ);
1785 cxtype |= CXp_PADVAR;
1790 svp = &GvSV(gv); /* symbol table variable */
1791 SAVEGENERICSV(*svp);
1794 iterdata = (void*)gv;
1800 PUSHBLOCK(cx, cxtype, SP);
1802 PUSHLOOP(cx, iterdata, MARK);
1804 PUSHLOOP(cx, svp, MARK);
1806 if (PL_op->op_flags & OPf_STACKED) {
1807 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1808 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1810 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1811 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1812 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1813 looks_like_number((SV*)cx->blk_loop.iterary) &&
1814 *SvPVX(cx->blk_loop.iterary) != '0'))
1816 if (SvNV(sv) < IV_MIN ||
1817 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1818 DIE(aTHX_ "Range iterator outside integer range");
1819 cx->blk_loop.iterix = SvIV(sv);
1820 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1823 cx->blk_loop.iterlval = newSVsv(sv);
1827 cx->blk_loop.iterary = PL_curstack;
1828 AvFILLp(PL_curstack) = SP - PL_stack_base;
1829 cx->blk_loop.iterix = MARK - PL_stack_base;
1838 register PERL_CONTEXT *cx;
1839 I32 gimme = GIMME_V;
1845 PUSHBLOCK(cx, CXt_LOOP, SP);
1846 PUSHLOOP(cx, 0, SP);
1854 register PERL_CONTEXT *cx;
1862 newsp = PL_stack_base + cx->blk_loop.resetsp;
1865 if (gimme == G_VOID)
1867 else if (gimme == G_SCALAR) {
1869 *++newsp = sv_mortalcopy(*SP);
1871 *++newsp = &PL_sv_undef;
1875 *++newsp = sv_mortalcopy(*++mark);
1876 TAINT_NOT; /* Each item is independent */
1882 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1883 PL_curpm = newpm; /* ... and pop $1 et al */
1895 register PERL_CONTEXT *cx;
1896 bool popsub2 = FALSE;
1897 bool clear_errsv = FALSE;
1904 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1905 if (cxstack_ix == PL_sortcxix
1906 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1908 if (cxstack_ix > PL_sortcxix)
1909 dounwind(PL_sortcxix);
1910 AvARRAY(PL_curstack)[1] = *SP;
1911 PL_stack_sp = PL_stack_base + 1;
1916 cxix = dopoptosub(cxstack_ix);
1918 DIE(aTHX_ "Can't return outside a subroutine");
1919 if (cxix < cxstack_ix)
1923 switch (CxTYPE(cx)) {
1928 if (!(PL_in_eval & EVAL_KEEPERR))
1934 if (optype == OP_REQUIRE &&
1935 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1937 /* Unassume the success we assumed earlier. */
1938 SV *nsv = cx->blk_eval.old_namesv;
1939 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1940 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1947 DIE(aTHX_ "panic: return");
1951 if (gimme == G_SCALAR) {
1954 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1956 *++newsp = SvREFCNT_inc(*SP);
1961 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1963 *++newsp = sv_mortalcopy(sv);
1968 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1971 *++newsp = sv_mortalcopy(*SP);
1974 *++newsp = &PL_sv_undef;
1976 else if (gimme == G_ARRAY) {
1977 while (++MARK <= SP) {
1978 *++newsp = (popsub2 && SvTEMP(*MARK))
1979 ? *MARK : sv_mortalcopy(*MARK);
1980 TAINT_NOT; /* Each item is independent */
1983 PL_stack_sp = newsp;
1985 /* Stack values are safe: */
1987 POPSUB(cx,sv); /* release CV and @_ ... */
1991 PL_curpm = newpm; /* ... and pop $1 et al */
1997 return pop_return();
2004 register PERL_CONTEXT *cx;
2014 if (PL_op->op_flags & OPf_SPECIAL) {
2015 cxix = dopoptoloop(cxstack_ix);
2017 DIE(aTHX_ "Can't \"last\" outside a loop block");
2020 cxix = dopoptolabel(cPVOP->op_pv);
2022 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2024 if (cxix < cxstack_ix)
2029 switch (CxTYPE(cx)) {
2032 newsp = PL_stack_base + cx->blk_loop.resetsp;
2033 nextop = cx->blk_loop.last_op->op_next;
2037 nextop = pop_return();
2041 nextop = pop_return();
2045 nextop = pop_return();
2048 DIE(aTHX_ "panic: last");
2052 if (gimme == G_SCALAR) {
2054 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2055 ? *SP : sv_mortalcopy(*SP);
2057 *++newsp = &PL_sv_undef;
2059 else if (gimme == G_ARRAY) {
2060 while (++MARK <= SP) {
2061 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2062 ? *MARK : sv_mortalcopy(*MARK);
2063 TAINT_NOT; /* Each item is independent */
2069 /* Stack values are safe: */
2072 POPLOOP(cx); /* release loop vars ... */
2076 POPSUB(cx,sv); /* release CV and @_ ... */
2079 PL_curpm = newpm; /* ... and pop $1 et al */
2089 register PERL_CONTEXT *cx;
2092 if (PL_op->op_flags & OPf_SPECIAL) {
2093 cxix = dopoptoloop(cxstack_ix);
2095 DIE(aTHX_ "Can't \"next\" outside a loop block");
2098 cxix = dopoptolabel(cPVOP->op_pv);
2100 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2102 if (cxix < cxstack_ix)
2105 /* clear off anything above the scope we're re-entering, but
2106 * save the rest until after a possible continue block */
2107 inner = PL_scopestack_ix;
2109 if (PL_scopestack_ix < inner)
2110 leave_scope(PL_scopestack[PL_scopestack_ix]);
2111 return cx->blk_loop.next_op;
2117 register PERL_CONTEXT *cx;
2120 if (PL_op->op_flags & OPf_SPECIAL) {
2121 cxix = dopoptoloop(cxstack_ix);
2123 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2126 cxix = dopoptolabel(cPVOP->op_pv);
2128 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2130 if (cxix < cxstack_ix)
2134 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2135 LEAVE_SCOPE(oldsave);
2136 return cx->blk_loop.redo_op;
2140 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2144 static char too_deep[] = "Target of goto is too deeply nested";
2147 Perl_croak(aTHX_ too_deep);
2148 if (o->op_type == OP_LEAVE ||
2149 o->op_type == OP_SCOPE ||
2150 o->op_type == OP_LEAVELOOP ||
2151 o->op_type == OP_LEAVETRY)
2153 *ops++ = cUNOPo->op_first;
2155 Perl_croak(aTHX_ too_deep);
2158 if (o->op_flags & OPf_KIDS) {
2159 /* First try all the kids at this level, since that's likeliest. */
2160 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2161 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2162 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2165 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2166 if (kid == PL_lastgotoprobe)
2168 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2170 (ops[-1]->op_type != OP_NEXTSTATE &&
2171 ops[-1]->op_type != OP_DBSTATE)))
2173 if ((o = dofindlabel(kid, label, ops, oplimit)))
2192 register PERL_CONTEXT *cx;
2193 #define GOTO_DEPTH 64
2194 OP *enterops[GOTO_DEPTH];
2196 int do_dump = (PL_op->op_type == OP_DUMP);
2197 static char must_have_label[] = "goto must have label";
2200 if (PL_op->op_flags & OPf_STACKED) {
2204 /* This egregious kludge implements goto &subroutine */
2205 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2207 register PERL_CONTEXT *cx;
2208 CV* cv = (CV*)SvRV(sv);
2214 if (!CvROOT(cv) && !CvXSUB(cv)) {
2219 /* autoloaded stub? */
2220 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2222 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2223 GvNAMELEN(gv), FALSE);
2224 if (autogv && (cv = GvCV(autogv)))
2226 tmpstr = sv_newmortal();
2227 gv_efullname3(tmpstr, gv, Nullch);
2228 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2230 DIE(aTHX_ "Goto undefined subroutine");
2233 /* First do some returnish stuff. */
2234 cxix = dopoptosub(cxstack_ix);
2236 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2237 if (cxix < cxstack_ix)
2241 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2243 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2244 /* put @_ back onto stack */
2245 AV* av = cx->blk_sub.argarray;
2247 items = AvFILLp(av) + 1;
2249 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2250 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2251 PL_stack_sp += items;
2252 #ifndef USE_5005THREADS
2253 SvREFCNT_dec(GvAV(PL_defgv));
2254 GvAV(PL_defgv) = cx->blk_sub.savearray;
2255 #endif /* USE_5005THREADS */
2256 /* abandon @_ if it got reified */
2258 (void)sv_2mortal((SV*)av); /* delay until return */
2260 av_extend(av, items-1);
2261 AvFLAGS(av) = AVf_REIFY;
2262 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2265 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2267 #ifdef USE_5005THREADS
2268 av = (AV*)PL_curpad[0];
2270 av = GvAV(PL_defgv);
2272 items = AvFILLp(av) + 1;
2274 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2275 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2276 PL_stack_sp += items;
2278 if (CxTYPE(cx) == CXt_SUB &&
2279 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2280 SvREFCNT_dec(cx->blk_sub.cv);
2281 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2282 LEAVE_SCOPE(oldsave);
2284 /* Now do some callish stuff. */
2287 #ifdef PERL_XSUB_OLDSTYLE
2288 if (CvOLDSTYLE(cv)) {
2289 I32 (*fp3)(int,int,int);
2294 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2295 items = (*fp3)(CvXSUBANY(cv).any_i32,
2296 mark - PL_stack_base + 1,
2298 SP = PL_stack_base + items;
2301 #endif /* PERL_XSUB_OLDSTYLE */
2306 PL_stack_sp--; /* There is no cv arg. */
2307 /* Push a mark for the start of arglist */
2309 (void)(*CvXSUB(cv))(aTHX_ cv);
2310 /* Pop the current context like a decent sub should */
2311 POPBLOCK(cx, PL_curpm);
2312 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2315 return pop_return();
2318 AV* padlist = CvPADLIST(cv);
2319 SV** svp = AvARRAY(padlist);
2320 if (CxTYPE(cx) == CXt_EVAL) {
2321 PL_in_eval = cx->blk_eval.old_in_eval;
2322 PL_eval_root = cx->blk_eval.old_eval_root;
2323 cx->cx_type = CXt_SUB;
2324 cx->blk_sub.hasargs = 0;
2326 cx->blk_sub.cv = cv;
2327 cx->blk_sub.olddepth = CvDEPTH(cv);
2329 if (CvDEPTH(cv) < 2)
2330 (void)SvREFCNT_inc(cv);
2331 else { /* save temporaries on recursion? */
2332 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2333 sub_crush_depth(cv);
2334 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2335 AV *newpad = newAV();
2336 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2337 I32 ix = AvFILLp((AV*)svp[1]);
2338 I32 names_fill = AvFILLp((AV*)svp[0]);
2339 svp = AvARRAY(svp[0]);
2340 for ( ;ix > 0; ix--) {
2341 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2342 char *name = SvPVX(svp[ix]);
2343 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2346 /* outer lexical or anon code */
2347 av_store(newpad, ix,
2348 SvREFCNT_inc(oldpad[ix]) );
2350 else { /* our own lexical */
2352 av_store(newpad, ix, sv = (SV*)newAV());
2353 else if (*name == '%')
2354 av_store(newpad, ix, sv = (SV*)newHV());
2356 av_store(newpad, ix, sv = NEWSV(0,0));
2360 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2361 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2364 av_store(newpad, ix, sv = NEWSV(0,0));
2368 if (cx->blk_sub.hasargs) {
2371 av_store(newpad, 0, (SV*)av);
2372 AvFLAGS(av) = AVf_REIFY;
2374 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2375 AvFILLp(padlist) = CvDEPTH(cv);
2376 svp = AvARRAY(padlist);
2379 #ifdef USE_5005THREADS
2380 if (!cx->blk_sub.hasargs) {
2381 AV* av = (AV*)PL_curpad[0];
2383 items = AvFILLp(av) + 1;
2385 /* Mark is at the end of the stack. */
2387 Copy(AvARRAY(av), SP + 1, items, SV*);
2392 #endif /* USE_5005THREADS */
2393 SAVEVPTR(PL_curpad);
2394 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2395 #ifndef USE_5005THREADS
2396 if (cx->blk_sub.hasargs)
2397 #endif /* USE_5005THREADS */
2399 AV* av = (AV*)PL_curpad[0];
2402 #ifndef USE_5005THREADS
2403 cx->blk_sub.savearray = GvAV(PL_defgv);
2404 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2405 #endif /* USE_5005THREADS */
2406 cx->blk_sub.oldcurpad = PL_curpad;
2407 cx->blk_sub.argarray = av;
2410 if (items >= AvMAX(av) + 1) {
2412 if (AvARRAY(av) != ary) {
2413 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2414 SvPVX(av) = (char*)ary;
2416 if (items >= AvMAX(av) + 1) {
2417 AvMAX(av) = items - 1;
2418 Renew(ary,items+1,SV*);
2420 SvPVX(av) = (char*)ary;
2423 Copy(mark,AvARRAY(av),items,SV*);
2424 AvFILLp(av) = items - 1;
2425 assert(!AvREAL(av));
2432 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2434 * We do not care about using sv to call CV;
2435 * it's for informational purposes only.
2437 SV *sv = GvSV(PL_DBsub);
2440 if (PERLDB_SUB_NN) {
2441 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2444 gv_efullname3(sv, CvGV(cv), Nullch);
2447 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2448 PUSHMARK( PL_stack_sp );
2449 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2453 RETURNOP(CvSTART(cv));
2457 label = SvPV(sv,n_a);
2458 if (!(do_dump || *label))
2459 DIE(aTHX_ must_have_label);
2462 else if (PL_op->op_flags & OPf_SPECIAL) {
2464 DIE(aTHX_ must_have_label);
2467 label = cPVOP->op_pv;
2469 if (label && *label) {
2471 bool leaving_eval = FALSE;
2472 PERL_CONTEXT *last_eval_cx = 0;
2476 PL_lastgotoprobe = 0;
2478 for (ix = cxstack_ix; ix >= 0; ix--) {
2480 switch (CxTYPE(cx)) {
2482 leaving_eval = TRUE;
2483 if (CxREALEVAL(cx)) {
2484 gotoprobe = (last_eval_cx ?
2485 last_eval_cx->blk_eval.old_eval_root :
2490 /* else fall through */
2492 gotoprobe = cx->blk_oldcop->op_sibling;
2498 gotoprobe = cx->blk_oldcop->op_sibling;
2500 gotoprobe = PL_main_root;
2503 if (CvDEPTH(cx->blk_sub.cv)) {
2504 gotoprobe = CvROOT(cx->blk_sub.cv);
2510 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2513 DIE(aTHX_ "panic: goto");
2514 gotoprobe = PL_main_root;
2518 retop = dofindlabel(gotoprobe, label,
2519 enterops, enterops + GOTO_DEPTH);
2523 PL_lastgotoprobe = gotoprobe;
2526 DIE(aTHX_ "Can't find label %s", label);
2528 /* if we're leaving an eval, check before we pop any frames
2529 that we're not going to punt, otherwise the error
2532 if (leaving_eval && *enterops && enterops[1]) {
2534 for (i = 1; enterops[i]; i++)
2535 if (enterops[i]->op_type == OP_ENTERITER)
2536 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2539 /* pop unwanted frames */
2541 if (ix < cxstack_ix) {
2548 oldsave = PL_scopestack[PL_scopestack_ix];
2549 LEAVE_SCOPE(oldsave);
2552 /* push wanted frames */
2554 if (*enterops && enterops[1]) {
2556 for (ix = 1; enterops[ix]; ix++) {
2557 PL_op = enterops[ix];
2558 /* Eventually we may want to stack the needed arguments
2559 * for each op. For now, we punt on the hard ones. */
2560 if (PL_op->op_type == OP_ENTERITER)
2561 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2562 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2570 if (!retop) retop = PL_main_start;
2572 PL_restartop = retop;
2573 PL_do_undump = TRUE;
2577 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2578 PL_do_undump = FALSE;
2594 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2598 PL_exit_flags |= PERL_EXIT_EXPECTED;
2600 PUSHs(&PL_sv_undef);
2608 NV value = SvNVx(GvSV(cCOP->cop_gv));
2609 register I32 match = I_32(value);
2612 if (((NV)match) > value)
2613 --match; /* was fractional--truncate other way */
2615 match -= cCOP->uop.scop.scop_offset;
2618 else if (match > cCOP->uop.scop.scop_max)
2619 match = cCOP->uop.scop.scop_max;
2620 PL_op = cCOP->uop.scop.scop_next[match];
2630 PL_op = PL_op->op_next; /* can't assume anything */
2633 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2634 match -= cCOP->uop.scop.scop_offset;
2637 else if (match > cCOP->uop.scop.scop_max)
2638 match = cCOP->uop.scop.scop_max;
2639 PL_op = cCOP->uop.scop.scop_next[match];
2648 S_save_lines(pTHX_ AV *array, SV *sv)
2650 register char *s = SvPVX(sv);
2651 register char *send = SvPVX(sv) + SvCUR(sv);
2653 register I32 line = 1;
2655 while (s && s < send) {
2656 SV *tmpstr = NEWSV(85,0);
2658 sv_upgrade(tmpstr, SVt_PVMG);
2659 t = strchr(s, '\n');
2665 sv_setpvn(tmpstr, s, t - s);
2666 av_store(array, line++, tmpstr);
2671 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2673 S_docatch_body(pTHX_ va_list args)
2675 return docatch_body();
2680 S_docatch_body(pTHX)
2687 S_docatch(pTHX_ OP *o)
2691 volatile PERL_SI *cursi = PL_curstackinfo;
2695 assert(CATCH_GET == TRUE);
2698 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2700 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2706 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2712 if (PL_restartop && cursi == PL_curstackinfo) {
2713 PL_op = PL_restartop;
2730 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2731 /* sv Text to convert to OP tree. */
2732 /* startop op_free() this to undo. */
2733 /* code Short string id of the caller. */
2735 dSP; /* Make POPBLOCK work. */
2738 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2742 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2743 char *tmpbuf = tbuf;
2749 /* switch to eval mode */
2751 if (PL_curcop == &PL_compiling) {
2752 SAVECOPSTASH_FREE(&PL_compiling);
2753 CopSTASH_set(&PL_compiling, PL_curstash);
2755 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2756 SV *sv = sv_newmortal();
2757 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2758 code, (unsigned long)++PL_evalseq,
2759 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2763 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2764 SAVECOPFILE_FREE(&PL_compiling);
2765 CopFILE_set(&PL_compiling, tmpbuf+2);
2766 SAVECOPLINE(&PL_compiling);
2767 CopLINE_set(&PL_compiling, 1);
2768 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2769 deleting the eval's FILEGV from the stash before gv_check() runs
2770 (i.e. before run-time proper). To work around the coredump that
2771 ensues, we always turn GvMULTI_on for any globals that were
2772 introduced within evals. See force_ident(). GSAR 96-10-12 */
2773 safestr = savepv(tmpbuf);
2774 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2776 #ifdef OP_IN_REGISTER
2781 PL_hints &= HINT_UTF8;
2784 PL_op->op_type = OP_ENTEREVAL;
2785 PL_op->op_flags = 0; /* Avoid uninit warning. */
2786 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2787 PUSHEVAL(cx, 0, Nullgv);
2788 rop = doeval(G_SCALAR, startop);
2789 POPBLOCK(cx,PL_curpm);
2792 (*startop)->op_type = OP_NULL;
2793 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2795 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2797 if (PL_curcop == &PL_compiling)
2798 PL_compiling.op_private = PL_hints;
2799 #ifdef OP_IN_REGISTER
2805 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2807 S_doeval(pTHX_ int gimme, OP** startop)
2815 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2816 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2821 /* set up a scratch pad */
2824 SAVEVPTR(PL_curpad);
2825 SAVESPTR(PL_comppad);
2826 SAVESPTR(PL_comppad_name);
2827 SAVEI32(PL_comppad_name_fill);
2828 SAVEI32(PL_min_intro_pending);
2829 SAVEI32(PL_max_intro_pending);
2832 for (i = cxstack_ix - 1; i >= 0; i--) {
2833 PERL_CONTEXT *cx = &cxstack[i];
2834 if (CxTYPE(cx) == CXt_EVAL)
2836 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2837 caller = cx->blk_sub.cv;
2842 SAVESPTR(PL_compcv);
2843 PL_compcv = (CV*)NEWSV(1104,0);
2844 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2845 CvEVAL_on(PL_compcv);
2846 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2847 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2849 #ifdef USE_5005THREADS
2850 CvOWNER(PL_compcv) = 0;
2851 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2852 MUTEX_INIT(CvMUTEXP(PL_compcv));
2853 #endif /* USE_5005THREADS */
2855 PL_comppad = newAV();
2856 av_push(PL_comppad, Nullsv);
2857 PL_curpad = AvARRAY(PL_comppad);
2858 PL_comppad_name = newAV();
2859 PL_comppad_name_fill = 0;
2860 PL_min_intro_pending = 0;
2862 #ifdef USE_5005THREADS
2863 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2864 PL_curpad[0] = (SV*)newAV();
2865 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2866 #endif /* USE_5005THREADS */
2868 comppadlist = newAV();
2869 AvREAL_off(comppadlist);
2870 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2871 av_store(comppadlist, 1, (SV*)PL_comppad);
2872 CvPADLIST(PL_compcv) = comppadlist;
2875 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2877 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2880 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2882 /* make sure we compile in the right package */
2884 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2885 SAVESPTR(PL_curstash);
2886 PL_curstash = CopSTASH(PL_curcop);
2888 SAVESPTR(PL_beginav);
2889 PL_beginav = newAV();
2890 SAVEFREESV(PL_beginav);
2891 SAVEI32(PL_error_count);
2893 /* try to compile it */
2895 PL_eval_root = Nullop;
2897 PL_curcop = &PL_compiling;
2898 PL_curcop->cop_arybase = 0;
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 #ifdef USE_5005THREADS
2937 MUTEX_LOCK(&PL_eval_mutex);
2939 COND_SIGNAL(&PL_eval_cond);
2940 MUTEX_UNLOCK(&PL_eval_mutex);
2941 #endif /* USE_5005THREADS */
2944 CopLINE_set(&PL_compiling, 0);
2946 *startop = PL_eval_root;
2947 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2948 CvOUTSIDE(PL_compcv) = Nullcv;
2950 SAVEFREEOP(PL_eval_root);
2952 scalarvoid(PL_eval_root);
2953 else if (gimme & G_ARRAY)
2956 scalar(PL_eval_root);
2958 DEBUG_x(dump_eval());
2960 /* Register with debugger: */
2961 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2962 CV *cv = get_cv("DB::postponed", FALSE);
2966 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2968 call_sv((SV*)cv, G_DISCARD);
2972 /* compiled okay, so do it */
2974 CvDEPTH(PL_compcv) = 1;
2975 SP = PL_stack_base + POPMARK; /* pop original mark */
2976 PL_op = saveop; /* The caller may need it. */
2977 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2978 #ifdef USE_5005THREADS
2979 MUTEX_LOCK(&PL_eval_mutex);
2981 COND_SIGNAL(&PL_eval_cond);
2982 MUTEX_UNLOCK(&PL_eval_mutex);
2983 #endif /* USE_5005THREADS */
2985 RETURNOP(PL_eval_start);
2989 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2991 STRLEN namelen = strlen(name);
2994 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2995 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2996 char *pmc = SvPV_nolen(pmcsv);
2999 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3000 fp = PerlIO_open(name, mode);
3003 if (PerlLIO_stat(name, &pmstat) < 0 ||
3004 pmstat.st_mtime < pmcstat.st_mtime)
3006 fp = PerlIO_open(pmc, mode);
3009 fp = PerlIO_open(name, mode);
3012 SvREFCNT_dec(pmcsv);
3015 fp = PerlIO_open(name, mode);
3023 register PERL_CONTEXT *cx;
3027 char *tryname = Nullch;
3028 SV *namesv = Nullsv;
3030 I32 gimme = GIMME_V;
3031 PerlIO *tryrsfp = 0;
3033 int filter_has_file = 0;
3034 GV *filter_child_proc = 0;
3035 SV *filter_state = 0;
3041 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3042 UV rev = 0, ver = 0, sver = 0;
3044 U8 *s = (U8*)SvPVX(sv);
3045 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3047 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3050 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3053 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3056 if (PERL_REVISION < rev
3057 || (PERL_REVISION == rev
3058 && (PERL_VERSION < ver
3059 || (PERL_VERSION == ver
3060 && PERL_SUBVERSION < sver))))
3062 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3063 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3064 PERL_VERSION, PERL_SUBVERSION);
3066 if (ckWARN(WARN_PORTABLE))
3067 Perl_warner(aTHX_ WARN_PORTABLE,
3068 "v-string in use/require non-portable");
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".%03"UVuf"?)",
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 && !sv_isobject(loader))
3154 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3157 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3158 PTR2UV(SvRV(dirsv)), name);
3159 tryname = SvPVX(namesv);
3170 if (sv_isobject(loader))
3171 count = call_method("INC", G_ARRAY);
3173 count = call_sv(loader, G_ARRAY);
3183 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3187 if (SvTYPE(arg) == SVt_PVGV) {
3188 IO *io = GvIO((GV *)arg);
3193 tryrsfp = IoIFP(io);
3194 if (IoTYPE(io) == IoTYPE_PIPE) {
3195 /* reading from a child process doesn't
3196 nest -- when returning from reading
3197 the inner module, the outer one is
3198 unreadable (closed?) I've tried to
3199 save the gv to manage the lifespan of
3200 the pipe, but this didn't help. XXX */
3201 filter_child_proc = (GV *)arg;
3202 (void)SvREFCNT_inc(filter_child_proc);
3205 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3206 PerlIO_close(IoOFP(io));
3218 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3220 (void)SvREFCNT_inc(filter_sub);
3223 filter_state = SP[i];
3224 (void)SvREFCNT_inc(filter_state);
3228 tryrsfp = PerlIO_open("/dev/null",
3243 filter_has_file = 0;
3244 if (filter_child_proc) {
3245 SvREFCNT_dec(filter_child_proc);
3246 filter_child_proc = 0;
3249 SvREFCNT_dec(filter_state);
3253 SvREFCNT_dec(filter_sub);
3258 char *dir = SvPVx(dirsv, n_a);
3259 #ifdef MACOS_TRADITIONAL
3261 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3265 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3267 sv_setpv(namesv, unixdir);
3268 sv_catpv(namesv, unixname);
3270 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3273 TAINT_PROPER("require");
3274 tryname = SvPVX(namesv);
3275 #ifdef MACOS_TRADITIONAL
3277 /* Convert slashes in the name part, but not the directory part, to colons */
3279 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3283 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3285 if (tryname[0] == '.' && tryname[1] == '/')
3293 SAVECOPFILE_FREE(&PL_compiling);
3294 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3295 SvREFCNT_dec(namesv);
3297 if (PL_op->op_type == OP_REQUIRE) {
3298 char *msgstr = name;
3299 if (namesv) { /* did we lookup @INC? */
3300 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3301 SV *dirmsgsv = NEWSV(0, 0);
3302 AV *ar = GvAVn(PL_incgv);
3304 sv_catpvn(msg, " in @INC", 8);
3305 if (instr(SvPVX(msg), ".h "))
3306 sv_catpv(msg, " (change .h to .ph maybe?)");
3307 if (instr(SvPVX(msg), ".ph "))
3308 sv_catpv(msg, " (did you run h2ph?)");
3309 sv_catpv(msg, " (@INC contains:");
3310 for (i = 0; i <= AvFILL(ar); i++) {
3311 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3312 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3313 sv_catsv(msg, dirmsgsv);
3315 sv_catpvn(msg, ")", 1);
3316 SvREFCNT_dec(dirmsgsv);
3317 msgstr = SvPV_nolen(msg);
3319 DIE(aTHX_ "Can't locate %s", msgstr);
3325 SETERRNO(0, SS$_NORMAL);
3327 /* Assume success here to prevent recursive requirement. */
3329 /* Check whether a hook in @INC has already filled %INC */
3330 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3331 (void)hv_store(GvHVn(PL_incgv), name, len,
3332 (hook_sv ? SvREFCNT_inc(hook_sv)
3333 : newSVpv(CopFILE(&PL_compiling), 0)),
3339 lex_start(sv_2mortal(newSVpvn("",0)));
3340 SAVEGENERICSV(PL_rsfp_filters);
3341 PL_rsfp_filters = Nullav;
3346 SAVESPTR(PL_compiling.cop_warnings);
3347 if (PL_dowarn & G_WARN_ALL_ON)
3348 PL_compiling.cop_warnings = pWARN_ALL ;
3349 else if (PL_dowarn & G_WARN_ALL_OFF)
3350 PL_compiling.cop_warnings = pWARN_NONE ;
3352 PL_compiling.cop_warnings = pWARN_STD ;
3353 SAVESPTR(PL_compiling.cop_io);
3354 PL_compiling.cop_io = Nullsv;
3356 if (filter_sub || filter_child_proc) {
3357 SV *datasv = filter_add(run_user_filter, Nullsv);
3358 IoLINES(datasv) = filter_has_file;
3359 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3360 IoTOP_GV(datasv) = (GV *)filter_state;
3361 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3364 /* switch to eval mode */
3365 push_return(PL_op->op_next);
3366 PUSHBLOCK(cx, CXt_EVAL, SP);
3367 PUSHEVAL(cx, name, Nullgv);
3369 SAVECOPLINE(&PL_compiling);
3370 CopLINE_set(&PL_compiling, 0);
3373 #ifdef USE_5005THREADS
3374 MUTEX_LOCK(&PL_eval_mutex);
3375 if (PL_eval_owner && PL_eval_owner != thr)
3376 while (PL_eval_owner)
3377 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3378 PL_eval_owner = thr;
3379 MUTEX_UNLOCK(&PL_eval_mutex);
3380 #endif /* USE_5005THREADS */
3381 return DOCATCH(doeval(gimme, NULL));
3386 return pp_require();
3392 register PERL_CONTEXT *cx;
3394 I32 gimme = GIMME_V, was = PL_sub_generation;
3395 char tbuf[TYPE_DIGITS(long) + 12];
3396 char *tmpbuf = tbuf;
3401 if (!SvPV(sv,len) || !len)
3403 TAINT_PROPER("eval");
3409 /* switch to eval mode */
3411 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3412 SV *sv = sv_newmortal();
3413 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3414 (unsigned long)++PL_evalseq,
3415 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3419 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3420 SAVECOPFILE_FREE(&PL_compiling);
3421 CopFILE_set(&PL_compiling, tmpbuf+2);
3422 SAVECOPLINE(&PL_compiling);
3423 CopLINE_set(&PL_compiling, 1);
3424 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3425 deleting the eval's FILEGV from the stash before gv_check() runs
3426 (i.e. before run-time proper). To work around the coredump that
3427 ensues, we always turn GvMULTI_on for any globals that were
3428 introduced within evals. See force_ident(). GSAR 96-10-12 */
3429 safestr = savepv(tmpbuf);
3430 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3432 PL_hints = PL_op->op_targ;
3433 SAVESPTR(PL_compiling.cop_warnings);
3434 if (specialWARN(PL_curcop->cop_warnings))
3435 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3437 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3438 SAVEFREESV(PL_compiling.cop_warnings);
3440 SAVESPTR(PL_compiling.cop_io);
3441 if (specialCopIO(PL_curcop->cop_io))
3442 PL_compiling.cop_io = PL_curcop->cop_io;
3444 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3445 SAVEFREESV(PL_compiling.cop_io);
3448 push_return(PL_op->op_next);
3449 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3450 PUSHEVAL(cx, 0, Nullgv);
3452 /* prepare to compile string */
3454 if (PERLDB_LINE && PL_curstash != PL_debstash)
3455 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3457 #ifdef USE_5005THREADS
3458 MUTEX_LOCK(&PL_eval_mutex);
3459 if (PL_eval_owner && PL_eval_owner != thr)
3460 while (PL_eval_owner)
3461 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3462 PL_eval_owner = thr;
3463 MUTEX_UNLOCK(&PL_eval_mutex);
3464 #endif /* USE_5005THREADS */
3465 ret = doeval(gimme, NULL);
3466 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3467 && ret != PL_op->op_next) { /* Successive compilation. */
3468 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3470 return DOCATCH(ret);
3480 register PERL_CONTEXT *cx;
3482 U8 save_flags = PL_op -> op_flags;
3487 retop = pop_return();
3490 if (gimme == G_VOID)
3492 else if (gimme == G_SCALAR) {
3495 if (SvFLAGS(TOPs) & SVs_TEMP)
3498 *MARK = sv_mortalcopy(TOPs);
3502 *MARK = &PL_sv_undef;
3507 /* in case LEAVE wipes old return values */
3508 for (mark = newsp + 1; mark <= SP; mark++) {
3509 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3510 *mark = sv_mortalcopy(*mark);
3511 TAINT_NOT; /* Each item is independent */
3515 PL_curpm = newpm; /* Don't pop $1 et al till now */
3518 assert(CvDEPTH(PL_compcv) == 1);
3520 CvDEPTH(PL_compcv) = 0;
3523 if (optype == OP_REQUIRE &&
3524 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3526 /* Unassume the success we assumed earlier. */
3527 SV *nsv = cx->blk_eval.old_namesv;
3528 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3529 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3530 /* die_where() did LEAVE, or we won't be here */
3534 if (!(save_flags & OPf_SPECIAL))
3544 register PERL_CONTEXT *cx;
3545 I32 gimme = GIMME_V;
3550 push_return(cLOGOP->op_other->op_next);
3551 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3554 PL_in_eval = EVAL_INEVAL;
3557 return DOCATCH(PL_op->op_next);
3567 register PERL_CONTEXT *cx;
3575 if (gimme == G_VOID)
3577 else if (gimme == G_SCALAR) {
3580 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3583 *MARK = sv_mortalcopy(TOPs);
3587 *MARK = &PL_sv_undef;
3592 /* in case LEAVE wipes old return values */
3593 for (mark = newsp + 1; mark <= SP; mark++) {
3594 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3595 *mark = sv_mortalcopy(*mark);
3596 TAINT_NOT; /* Each item is independent */
3600 PL_curpm = newpm; /* Don't pop $1 et al till now */
3608 S_doparseform(pTHX_ SV *sv)
3611 register char *s = SvPV_force(sv, len);
3612 register char *send = s + len;
3613 register char *base = Nullch;
3614 register I32 skipspaces = 0;
3615 bool noblank = FALSE;
3616 bool repeat = FALSE;
3617 bool postspace = FALSE;
3625 Perl_croak(aTHX_ "Null picture in formline");
3627 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3632 *fpc++ = FF_LINEMARK;
3633 noblank = repeat = FALSE;
3651 case ' ': case '\t':
3662 *fpc++ = FF_LITERAL;
3670 *fpc++ = skipspaces;
3674 *fpc++ = FF_NEWLINE;
3678 arg = fpc - linepc + 1;
3685 *fpc++ = FF_LINEMARK;
3686 noblank = repeat = FALSE;
3695 ischop = s[-1] == '^';
3701 arg = (s - base) - 1;
3703 *fpc++ = FF_LITERAL;
3712 *fpc++ = FF_LINEGLOB;
3714 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3715 arg = ischop ? 512 : 0;
3725 arg |= 256 + (s - f);
3727 *fpc++ = s - base; /* fieldsize for FETCH */
3728 *fpc++ = FF_DECIMAL;
3731 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3732 arg = ischop ? 512 : 0;
3734 s++; /* skip the '0' first */
3743 arg |= 256 + (s - f);
3745 *fpc++ = s - base; /* fieldsize for FETCH */
3746 *fpc++ = FF_0DECIMAL;
3751 bool ismore = FALSE;
3754 while (*++s == '>') ;
3755 prespace = FF_SPACE;
3757 else if (*s == '|') {
3758 while (*++s == '|') ;
3759 prespace = FF_HALFSPACE;
3764 while (*++s == '<') ;
3767 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3771 *fpc++ = s - base; /* fieldsize for FETCH */
3773 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3791 { /* need to jump to the next word */
3793 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3794 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3795 s = SvPVX(sv) + SvCUR(sv) + z;
3797 Copy(fops, s, arg, U16);
3799 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3804 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3806 * The original code was written in conjunction with BSD Computer Software
3807 * Research Group at University of California, Berkeley.
3809 * See also: "Optimistic Merge Sort" (SODA '92)
3811 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3813 * The code can be distributed under the same terms as Perl itself.
3818 #include <sys/types.h>
3822 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3823 #define Safefree(VAR) free(VAR)
3824 typedef int (*SVCOMPARE_t) (pTHX_ SV*, SV*);
3825 #endif /* TESTHARNESS */
3827 typedef char * aptr; /* pointer for arithmetic on sizes */
3828 typedef SV * gptr; /* pointers in our lists */
3830 /* Binary merge internal sort, with a few special mods
3831 ** for the special perl environment it now finds itself in.
3833 ** Things that were once options have been hotwired
3834 ** to values suitable for this use. In particular, we'll always
3835 ** initialize looking for natural runs, we'll always produce stable
3836 ** output, and we'll always do Peter McIlroy's binary merge.
3839 /* Pointer types for arithmetic and storage and convenience casts */
3841 #define APTR(P) ((aptr)(P))
3842 #define GPTP(P) ((gptr *)(P))
3843 #define GPPP(P) ((gptr **)(P))
3846 /* byte offset from pointer P to (larger) pointer Q */
3847 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3849 #define PSIZE sizeof(gptr)
3851 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3854 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3855 #define PNBYTE(N) ((N) << (PSHIFT))
3856 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3858 /* Leave optimization to compiler */
3859 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3860 #define PNBYTE(N) ((N) * (PSIZE))
3861 #define PINDEX(P, N) (GPTP(P) + (N))
3864 /* Pointer into other corresponding to pointer into this */
3865 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3867 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3870 /* Runs are identified by a pointer in the auxilliary list.
3871 ** The pointer is at the start of the list,
3872 ** and it points to the start of the next list.
3873 ** NEXT is used as an lvalue, too.
3876 #define NEXT(P) (*GPPP(P))
3879 /* PTHRESH is the minimum number of pairs with the same sense to justify
3880 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3881 ** not just elements, so PTHRESH == 8 means a run of 16.
3886 /* RTHRESH is the number of elements in a run that must compare low
3887 ** to the low element from the opposing run before we justify
3888 ** doing a binary rampup instead of single stepping.
3889 ** In random input, N in a row low should only happen with
3890 ** probability 2^(1-N), so we can risk that we are dealing
3891 ** with orderly input without paying much when we aren't.
3898 ** Overview of algorithm and variables.
3899 ** The array of elements at list1 will be organized into runs of length 2,
3900 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3901 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3903 ** Unless otherwise specified, pair pointers address the first of two elements.
3905 ** b and b+1 are a pair that compare with sense ``sense''.
3906 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3908 ** p2 parallels b in the list2 array, where runs are defined by
3911 ** t represents the ``top'' of the adjacent pairs that might extend
3912 ** the run beginning at b. Usually, t addresses a pair
3913 ** that compares with opposite sense from (b,b+1).
3914 ** However, it may also address a singleton element at the end of list1,
3915 ** or it may be equal to ``last'', the first element beyond list1.
3917 ** r addresses the Nth pair following b. If this would be beyond t,
3918 ** we back it off to t. Only when r is less than t do we consider the
3919 ** run long enough to consider checking.
3921 ** q addresses a pair such that the pairs at b through q already form a run.
3922 ** Often, q will equal b, indicating we only are sure of the pair itself.
3923 ** However, a search on the previous cycle may have revealed a longer run,
3924 ** so q may be greater than b.
3926 ** p is used to work back from a candidate r, trying to reach q,
3927 ** which would mean b through r would be a run. If we discover such a run,
3928 ** we start q at r and try to push it further towards t.
3929 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3930 ** In any event, after the check (if any), we have two main cases.
3932 ** 1) Short run. b <= q < p <= r <= t.
3933 ** b through q is a run (perhaps trivial)
3934 ** q through p are uninteresting pairs
3935 ** p through r is a run
3937 ** 2) Long run. b < r <= q < t.
3938 ** b through q is a run (of length >= 2 * PTHRESH)
3940 ** Note that degenerate cases are not only possible, but likely.
3941 ** For example, if the pair following b compares with opposite sense,
3942 ** then b == q < p == r == t.
3947 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3950 register gptr *b, *p, *q, *t, *p2;
3951 register gptr c, *last, *r;
3955 last = PINDEX(b, nmemb);
3956 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3957 for (p2 = list2; b < last; ) {
3958 /* We just started, or just reversed sense.
3959 ** Set t at end of pairs with the prevailing sense.
3961 for (p = b+2, t = p; ++p < last; t = ++p) {
3962 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3965 /* Having laid out the playing field, look for long runs */
3967 p = r = b + (2 * PTHRESH);
3968 if (r >= t) p = r = t; /* too short to care about */
3970 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3973 /* b through r is a (long) run.
3974 ** Extend it as far as possible.
3977 while (((p += 2) < t) &&
3978 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3979 r = p = q + 2; /* no simple pairs, no after-run */
3982 if (q > b) { /* run of greater than 2 at b */
3985 /* pick up singleton, if possible */
3987 ((t + 1) == last) &&
3988 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3989 savep = r = p = q = last;
3990 p2 = NEXT(p2) = p2 + (p - b);
3991 if (sense) while (b < --p) {
3998 while (q < p) { /* simple pairs */
3999 p2 = NEXT(p2) = p2 + 2;
4006 if (((b = p) == t) && ((t+1) == last)) {
4018 /* Overview of bmerge variables:
4020 ** list1 and list2 address the main and auxiliary arrays.
4021 ** They swap identities after each merge pass.
4022 ** Base points to the original list1, so we can tell if
4023 ** the pointers ended up where they belonged (or must be copied).
4025 ** When we are merging two lists, f1 and f2 are the next elements
4026 ** on the respective lists. l1 and l2 mark the end of the lists.
4027 ** tp2 is the current location in the merged list.
4029 ** p1 records where f1 started.
4030 ** After the merge, a new descriptor is built there.
4032 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4033 ** It is used to identify and delimit the runs.
4035 ** In the heat of determining where q, the greater of the f1/f2 elements,
4036 ** belongs in the other list, b, t and p, represent bottom, top and probe
4037 ** locations, respectively, in the other list.
4038 ** They make convenient temporary pointers in other places.
4044 Sort an array. Here is an example:
4046 sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
4052 Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4056 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4057 gptr *aux, *list2, *p2, *last;
4061 if (nmemb <= 1) return; /* sorted trivially */
4062 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4064 dynprep(aTHX_ list1, list2, nmemb, cmp);
4065 last = PINDEX(list2, nmemb);
4066 while (NEXT(list2) != last) {
4067 /* More than one run remains. Do some merging to reduce runs. */
4069 for (tp2 = p2 = list2; p2 != last;) {
4070 /* The new first run begins where the old second list ended.
4071 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4075 f2 = l1 = POTHER(t, list2, list1);
4076 if (t != last) t = NEXT(t);
4077 l2 = POTHER(t, list2, list1);
4079 while (f1 < l1 && f2 < l2) {
4080 /* If head 1 is larger than head 2, find ALL the elements
4081 ** in list 2 strictly less than head1, write them all,
4082 ** then head 1. Then compare the new heads, and repeat,
4083 ** until one or both lists are exhausted.
4085 ** In all comparisons (after establishing
4086 ** which head to merge) the item to merge
4087 ** (at pointer q) is the first operand of
4088 ** the comparison. When we want to know
4089 ** if ``q is strictly less than the other'',
4091 ** cmp(q, other) < 0
4092 ** because stability demands that we treat equality
4093 ** as high when q comes from l2, and as low when
4094 ** q was from l1. So we ask the question by doing
4095 ** cmp(q, other) <= sense
4096 ** and make sense == 0 when equality should look low,
4097 ** and -1 when equality should look high.
4101 if (cmp(aTHX_ *f1, *f2) <= 0) {
4102 q = f2; b = f1; t = l1;
4105 q = f1; b = f2; t = l2;
4112 ** Leave t at something strictly
4113 ** greater than q (or at the end of the list),
4114 ** and b at something strictly less than q.
4116 for (i = 1, run = 0 ;;) {
4117 if ((p = PINDEX(b, i)) >= t) {
4119 if (((p = PINDEX(t, -1)) > b) &&
4120 (cmp(aTHX_ *q, *p) <= sense))
4124 } else if (cmp(aTHX_ *q, *p) <= sense) {
4128 if (++run >= RTHRESH) i += i;
4132 /* q is known to follow b and must be inserted before t.
4133 ** Increment b, so the range of possibilities is [b,t).
4134 ** Round binary split down, to favor early appearance.
4135 ** Adjust b and t until q belongs just before t.
4140 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4141 if (cmp(aTHX_ *q, *p) <= sense) {
4147 /* Copy all the strictly low elements */
4150 FROMTOUPTO(f2, tp2, t);
4153 FROMTOUPTO(f1, tp2, t);
4159 /* Run out remaining list */
4161 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4162 } else FROMTOUPTO(f1, tp2, l1);
4163 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4168 last = PINDEX(list2, nmemb);
4170 if (base == list2) {
4171 last = PINDEX(list1, nmemb);
4172 FROMTOUPTO(list1, list2, last);
4179 sortcv(pTHX_ SV *a, SV *b)
4181 I32 oldsaveix = PL_savestack_ix;
4182 I32 oldscopeix = PL_scopestack_ix;
4184 GvSV(PL_firstgv) = a;
4185 GvSV(PL_secondgv) = b;
4186 PL_stack_sp = PL_stack_base;
4189 if (PL_stack_sp != PL_stack_base + 1)
4190 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4191 if (!SvNIOKp(*PL_stack_sp))
4192 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4193 result = SvIV(*PL_stack_sp);
4194 while (PL_scopestack_ix > oldscopeix) {
4197 leave_scope(oldsaveix);
4202 sortcv_stacked(pTHX_ SV *a, SV *b)
4204 I32 oldsaveix = PL_savestack_ix;
4205 I32 oldscopeix = PL_scopestack_ix;
4209 #ifdef USE_5005THREADS
4210 av = (AV*)PL_curpad[0];
4212 av = GvAV(PL_defgv);
4215 if (AvMAX(av) < 1) {
4216 SV** ary = AvALLOC(av);
4217 if (AvARRAY(av) != ary) {
4218 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4219 SvPVX(av) = (char*)ary;
4221 if (AvMAX(av) < 1) {
4224 SvPVX(av) = (char*)ary;
4231 PL_stack_sp = PL_stack_base;
4234 if (PL_stack_sp != PL_stack_base + 1)
4235 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4236 if (!SvNIOKp(*PL_stack_sp))
4237 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4238 result = SvIV(*PL_stack_sp);
4239 while (PL_scopestack_ix > oldscopeix) {
4242 leave_scope(oldsaveix);
4247 sortcv_xsub(pTHX_ SV *a, SV *b)
4250 I32 oldsaveix = PL_savestack_ix;
4251 I32 oldscopeix = PL_scopestack_ix;
4253 CV *cv=(CV*)PL_sortcop;
4261 (void)(*CvXSUB(cv))(aTHX_ cv);
4262 if (PL_stack_sp != PL_stack_base + 1)
4263 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4264 if (!SvNIOKp(*PL_stack_sp))
4265 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4266 result = SvIV(*PL_stack_sp);
4267 while (PL_scopestack_ix > oldscopeix) {
4270 leave_scope(oldsaveix);
4276 sv_ncmp(pTHX_ SV *a, SV *b)
4280 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4284 sv_i_ncmp(pTHX_ SV *a, SV *b)
4288 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4290 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4292 if (PL_amagic_generation) { \
4293 if (SvAMAGIC(left)||SvAMAGIC(right))\
4294 *svp = amagic_call(left, \
4302 amagic_ncmp(pTHX_ register SV *a, register SV *b)
4305 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4310 I32 i = SvIVX(tmpsv);
4320 return sv_ncmp(aTHX_ a, b);
4324 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
4327 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4332 I32 i = SvIVX(tmpsv);
4342 return sv_i_ncmp(aTHX_ a, b);
4346 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
4349 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4354 I32 i = SvIVX(tmpsv);
4364 return sv_cmp(str1, str2);
4368 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
4371 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4376 I32 i = SvIVX(tmpsv);
4386 return sv_cmp_locale(str1, str2);
4390 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4392 SV *datasv = FILTER_DATA(idx);
4393 int filter_has_file = IoLINES(datasv);
4394 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4395 SV *filter_state = (SV *)IoTOP_GV(datasv);
4396 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4399 /* I was having segfault trouble under Linux 2.2.5 after a
4400 parse error occured. (Had to hack around it with a test
4401 for PL_error_count == 0.) Solaris doesn't segfault --
4402 not sure where the trouble is yet. XXX */
4404 if (filter_has_file) {
4405 len = FILTER_READ(idx+1, buf_sv, maxlen);
4408 if (filter_sub && len >= 0) {
4419 PUSHs(sv_2mortal(newSViv(maxlen)));
4421 PUSHs(filter_state);
4424 count = call_sv(filter_sub, G_SCALAR);
4440 IoLINES(datasv) = 0;
4441 if (filter_child_proc) {
4442 SvREFCNT_dec(filter_child_proc);
4443 IoFMT_GV(datasv) = Nullgv;
4446 SvREFCNT_dec(filter_state);
4447 IoTOP_GV(datasv) = Nullgv;
4450 SvREFCNT_dec(filter_sub);
4451 IoBOTTOM_GV(datasv) = Nullgv;
4453 filter_del(run_user_filter);