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 if (cx->sb_iters > cx->sb_maxiters)
176 DIE(aTHX_ "Substitution loop");
178 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
179 cx->sb_rxtainted |= 2;
180 sv_catsv(dstr, POPs);
183 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
184 s == m, cx->sb_targ, NULL,
185 ((cx->sb_rflags & REXEC_COPY_STR)
186 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
187 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
189 SV *targ = cx->sb_targ;
191 sv_catpvn(dstr, s, cx->sb_strend - s);
192 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
194 (void)SvOOK_off(targ);
195 Safefree(SvPVX(targ));
196 SvPVX(targ) = SvPVX(dstr);
197 SvCUR_set(targ, SvCUR(dstr));
198 SvLEN_set(targ, SvLEN(dstr));
204 TAINT_IF(cx->sb_rxtainted & 1);
205 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
207 (void)SvPOK_only_UTF8(targ);
208 TAINT_IF(cx->sb_rxtainted);
212 LEAVE_SCOPE(cx->sb_oldsave);
214 RETURNOP(pm->op_next);
217 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
220 cx->sb_orig = orig = rx->subbeg;
222 cx->sb_strend = s + (cx->sb_strend - m);
224 cx->sb_m = m = rx->startp[0] + orig;
226 sv_catpvn(dstr, s, m-s);
227 cx->sb_s = rx->endp[0] + orig;
228 { /* Update the pos() information. */
229 SV *sv = cx->sb_targ;
232 if (SvTYPE(sv) < SVt_PVMG)
233 (void)SvUPGRADE(sv, SVt_PVMG);
234 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
235 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
236 mg = mg_find(sv, PERL_MAGIC_regex_global);
243 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
244 rxres_save(&cx->sb_rxres, rx);
245 RETURNOP(pm->op_pmreplstart);
249 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
254 if (!p || p[1] < rx->nparens) {
255 i = 6 + rx->nparens * 2;
263 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
264 RX_MATCH_COPIED_off(rx);
268 *p++ = PTR2UV(rx->subbeg);
269 *p++ = (UV)rx->sublen;
270 for (i = 0; i <= rx->nparens; ++i) {
271 *p++ = (UV)rx->startp[i];
272 *p++ = (UV)rx->endp[i];
277 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
282 if (RX_MATCH_COPIED(rx))
283 Safefree(rx->subbeg);
284 RX_MATCH_COPIED_set(rx, *p);
289 rx->subbeg = INT2PTR(char*,*p++);
290 rx->sublen = (I32)(*p++);
291 for (i = 0; i <= rx->nparens; ++i) {
292 rx->startp[i] = (I32)(*p++);
293 rx->endp[i] = (I32)(*p++);
298 Perl_rxres_free(pTHX_ void **rsp)
303 Safefree(INT2PTR(char*,*p));
311 dSP; dMARK; dORIGMARK;
312 register SV *tmpForm = *++MARK;
319 register SV *sv = Nullsv;
324 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
325 char *chophere = Nullch;
326 char *linemark = Nullch;
328 bool gotsome = FALSE;
330 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
331 bool item_is_utf = FALSE;
333 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
334 if (SvREADONLY(tmpForm)) {
335 SvREADONLY_off(tmpForm);
336 doparseform(tmpForm);
337 SvREADONLY_on(tmpForm);
340 doparseform(tmpForm);
343 SvPV_force(PL_formtarget, len);
344 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
346 f = SvPV(tmpForm, len);
347 /* need to jump to the next word */
348 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
357 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
358 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
359 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
360 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
361 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
363 case FF_CHECKNL: name = "CHECKNL"; break;
364 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
365 case FF_SPACE: name = "SPACE"; break;
366 case FF_HALFSPACE: name = "HALFSPACE"; break;
367 case FF_ITEM: name = "ITEM"; break;
368 case FF_CHOP: name = "CHOP"; break;
369 case FF_LINEGLOB: name = "LINEGLOB"; break;
370 case FF_NEWLINE: name = "NEWLINE"; break;
371 case FF_MORE: name = "MORE"; break;
372 case FF_LINEMARK: name = "LINEMARK"; break;
373 case FF_END: name = "END"; break;
374 case FF_0DECIMAL: name = "0DECIMAL"; break;
377 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
379 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
407 if (ckWARN(WARN_SYNTAX))
408 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
413 item = s = SvPV(sv, len);
416 itemsize = sv_len_utf8(sv);
417 if (itemsize != len) {
419 if (itemsize > fieldsize) {
420 itemsize = fieldsize;
421 itembytes = itemsize;
422 sv_pos_u2b(sv, &itembytes, 0);
426 send = chophere = s + itembytes;
436 sv_pos_b2u(sv, &itemsize);
441 if (itemsize > fieldsize)
442 itemsize = fieldsize;
443 send = chophere = s + itemsize;
455 item = s = SvPV(sv, len);
458 itemsize = sv_len_utf8(sv);
459 if (itemsize != len) {
461 if (itemsize <= fieldsize) {
462 send = chophere = s + itemsize;
473 itemsize = fieldsize;
474 itembytes = itemsize;
475 sv_pos_u2b(sv, &itembytes, 0);
476 send = chophere = s + itembytes;
477 while (s < send || (s == send && isSPACE(*s))) {
487 if (strchr(PL_chopset, *s))
492 itemsize = chophere - item;
493 sv_pos_b2u(sv, &itemsize);
500 if (itemsize <= fieldsize) {
501 send = chophere = s + itemsize;
512 itemsize = fieldsize;
513 send = chophere = s + itemsize;
514 while (s < send || (s == send && isSPACE(*s))) {
524 if (strchr(PL_chopset, *s))
529 itemsize = chophere - item;
534 arg = fieldsize - itemsize;
543 arg = fieldsize - itemsize;
557 if (UTF8_IS_CONTINUED(*s)) {
558 STRLEN skip = UTF8SKIP(s);
575 if ( !((*t++ = *s++) & ~31) )
583 int ch = *t++ = *s++;
586 if ( !((*t++ = *s++) & ~31) )
595 while (*s && isSPACE(*s))
602 item = s = SvPV(sv, len);
604 item_is_utf = FALSE; /* XXX is this correct? */
616 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
617 sv_catpvn(PL_formtarget, item, itemsize);
618 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
619 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
624 /* If the field is marked with ^ and the value is undefined,
627 if ((arg & 512) && !SvOK(sv)) {
635 /* Formats aren't yet marked for locales, so assume "yes". */
637 STORE_NUMERIC_STANDARD_SET_LOCAL();
638 #if defined(USE_LONG_DOUBLE)
640 sprintf(t, "%#*.*" PERL_PRIfldbl,
641 (int) fieldsize, (int) arg & 255, value);
643 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
648 (int) fieldsize, (int) arg & 255, value);
651 (int) fieldsize, value);
654 RESTORE_NUMERIC_STANDARD();
660 /* If the field is marked with ^ and the value is undefined,
663 if ((arg & 512) && !SvOK(sv)) {
671 /* Formats aren't yet marked for locales, so assume "yes". */
673 STORE_NUMERIC_STANDARD_SET_LOCAL();
674 #if defined(USE_LONG_DOUBLE)
676 sprintf(t, "%#0*.*" PERL_PRIfldbl,
677 (int) fieldsize, (int) arg & 255, value);
678 /* is this legal? I don't have long doubles */
680 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
684 sprintf(t, "%#0*.*f",
685 (int) fieldsize, (int) arg & 255, value);
688 (int) fieldsize, value);
691 RESTORE_NUMERIC_STANDARD();
698 while (t-- > linemark && *t == ' ') ;
706 if (arg) { /* repeat until fields exhausted? */
708 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
709 lines += FmLINES(PL_formtarget);
712 if (strnEQ(linemark, linemark - arg, arg))
713 DIE(aTHX_ "Runaway format");
715 FmLINES(PL_formtarget) = lines;
717 RETURNOP(cLISTOP->op_first);
730 while (*s && isSPACE(*s) && s < send)
734 arg = fieldsize - itemsize;
741 if (strnEQ(s," ",3)) {
742 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
753 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
754 FmLINES(PL_formtarget) += lines;
766 if (PL_stack_base + *PL_markstack_ptr == SP) {
768 if (GIMME_V == G_SCALAR)
769 XPUSHs(sv_2mortal(newSViv(0)));
770 RETURNOP(PL_op->op_next->op_next);
772 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
773 pp_pushmark(); /* push dst */
774 pp_pushmark(); /* push src */
775 ENTER; /* enter outer scope */
778 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
780 ENTER; /* enter inner scope */
783 src = PL_stack_base[*PL_markstack_ptr];
788 if (PL_op->op_type == OP_MAPSTART)
789 pp_pushmark(); /* push top */
790 return ((LOGOP*)PL_op->op_next)->op_other;
795 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
801 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
807 /* first, move source pointer to the next item in the source list */
808 ++PL_markstack_ptr[-1];
810 /* if there are new items, push them into the destination list */
812 /* might need to make room back there first */
813 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
814 /* XXX this implementation is very pessimal because the stack
815 * is repeatedly extended for every set of items. Is possible
816 * to do this without any stack extension or copying at all
817 * by maintaining a separate list over which the map iterates
818 * (like foreach does). --gsar */
820 /* everything in the stack after the destination list moves
821 * towards the end the stack by the amount of room needed */
822 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
824 /* items to shift up (accounting for the moved source pointer) */
825 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
827 /* This optimization is by Ben Tilly and it does
828 * things differently from what Sarathy (gsar)
829 * is describing. The downside of this optimization is
830 * that leaves "holes" (uninitialized and hopefully unused areas)
831 * to the Perl stack, but on the other hand this
832 * shouldn't be a problem. If Sarathy's idea gets
833 * implemented, this optimization should become
834 * irrelevant. --jhi */
836 shift = count; /* Avoid shifting too often --Ben Tilly */
841 PL_markstack_ptr[-1] += shift;
842 *PL_markstack_ptr += shift;
846 /* copy the new items down to the destination list */
847 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
849 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
851 LEAVE; /* exit inner scope */
854 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
857 (void)POPMARK; /* pop top */
858 LEAVE; /* exit outer scope */
859 (void)POPMARK; /* pop src */
860 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
861 (void)POPMARK; /* pop dst */
862 SP = PL_stack_base + POPMARK; /* pop original mark */
863 if (gimme == G_SCALAR) {
867 else if (gimme == G_ARRAY)
874 ENTER; /* enter inner scope */
877 /* set $_ to the new source item */
878 src = PL_stack_base[PL_markstack_ptr[-1]];
882 RETURNOP(cLOGOP->op_other);
888 dSP; dMARK; dORIGMARK;
890 SV **myorigmark = ORIGMARK;
896 OP* nextop = PL_op->op_next;
898 bool hasargs = FALSE;
901 if (gimme != G_ARRAY) {
907 SAVEVPTR(PL_sortcop);
908 if (PL_op->op_flags & OPf_STACKED) {
909 if (PL_op->op_flags & OPf_SPECIAL) {
910 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
911 kid = kUNOP->op_first; /* pass rv2gv */
912 kid = kUNOP->op_first; /* pass leave */
913 PL_sortcop = kid->op_next;
914 stash = CopSTASH(PL_curcop);
917 cv = sv_2cv(*++MARK, &stash, &gv, 0);
918 if (cv && SvPOK(cv)) {
920 char *proto = SvPV((SV*)cv, n_a);
921 if (proto && strEQ(proto, "$$")) {
925 if (!(cv && CvROOT(cv))) {
926 if (cv && CvXSUB(cv)) {
930 SV *tmpstr = sv_newmortal();
931 gv_efullname3(tmpstr, gv, Nullch);
932 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
936 DIE(aTHX_ "Undefined subroutine in sort");
941 PL_sortcop = (OP*)cv;
943 PL_sortcop = CvSTART(cv);
944 SAVEVPTR(CvROOT(cv)->op_ppaddr);
945 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
948 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
954 stash = CopSTASH(PL_curcop);
958 while (MARK < SP) { /* This may or may not shift down one here. */
960 if ((*up = *++MARK)) { /* Weed out nulls. */
962 if (!PL_sortcop && !SvPOK(*up)) {
967 (void)sv_2pv(*up, &n_a);
972 max = --up - myorigmark;
977 bool oldcatch = CATCH_GET;
983 PUSHSTACKi(PERLSI_SORT);
984 if (!hasargs && !is_xsub) {
985 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
986 SAVESPTR(PL_firstgv);
987 SAVESPTR(PL_secondgv);
988 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
989 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
990 PL_sortstash = stash;
992 #ifdef USE_5005THREADS
993 sv_lock((SV *)PL_firstgv);
994 sv_lock((SV *)PL_secondgv);
996 SAVESPTR(GvSV(PL_firstgv));
997 SAVESPTR(GvSV(PL_secondgv));
1000 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1001 if (!(PL_op->op_flags & OPf_SPECIAL)) {
1002 cx->cx_type = CXt_SUB;
1003 cx->blk_gimme = G_SCALAR;
1006 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1008 PL_sortcxix = cxstack_ix;
1010 if (hasargs && !is_xsub) {
1011 /* This is mostly copied from pp_entersub */
1012 AV *av = (AV*)PL_curpad[0];
1014 #ifndef USE_5005THREADS
1015 cx->blk_sub.savearray = GvAV(PL_defgv);
1016 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1017 #endif /* USE_5005THREADS */
1018 cx->blk_sub.oldcurpad = PL_curpad;
1019 cx->blk_sub.argarray = av;
1021 sortsv((myorigmark+1), max,
1022 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1024 POPBLOCK(cx,PL_curpm);
1025 PL_stack_sp = newsp;
1027 CATCH_SET(oldcatch);
1032 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1033 sortsv(ORIGMARK+1, max,
1034 (PL_op->op_private & OPpSORT_NUMERIC)
1035 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1036 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1037 : ( overloading ? amagic_ncmp : sv_ncmp))
1038 : ( IN_LOCALE_RUNTIME
1041 : sv_cmp_locale_static)
1042 : ( overloading ? amagic_cmp : sv_cmp_static)));
1043 if (PL_op->op_private & OPpSORT_REVERSE) {
1044 SV **p = ORIGMARK+1;
1045 SV **q = ORIGMARK+max;
1055 PL_stack_sp = ORIGMARK + max;
1063 if (GIMME == G_ARRAY)
1065 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1066 return cLOGOP->op_other;
1075 if (GIMME == G_ARRAY) {
1076 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1080 SV *targ = PAD_SV(PL_op->op_targ);
1083 if (PL_op->op_private & OPpFLIP_LINENUM) {
1085 flip = PL_last_in_gv
1086 && (gp_io = GvIO(PL_last_in_gv))
1087 && SvIV(sv) == (IV)IoLINES(gp_io);
1092 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1093 if (PL_op->op_flags & OPf_SPECIAL) {
1101 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1114 if (GIMME == G_ARRAY) {
1120 if (SvGMAGICAL(left))
1122 if (SvGMAGICAL(right))
1125 if (SvNIOKp(left) || !SvPOKp(left) ||
1126 SvNIOKp(right) || !SvPOKp(right) ||
1127 (looks_like_number(left) && *SvPVX(left) != '0' &&
1128 looks_like_number(right) && *SvPVX(right) != '0'))
1130 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1131 DIE(aTHX_ "Range iterator outside integer range");
1142 sv = sv_2mortal(newSViv(i++));
1147 SV *final = sv_mortalcopy(right);
1149 char *tmps = SvPV(final, len);
1151 sv = sv_mortalcopy(left);
1153 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1155 if (strEQ(SvPVX(sv),tmps))
1157 sv = sv_2mortal(newSVsv(sv));
1164 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1166 if ((PL_op->op_private & OPpFLIP_LINENUM)
1167 ? (GvIO(PL_last_in_gv)
1168 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1170 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1171 sv_catpv(targ, "E0");
1182 S_dopoptolabel(pTHX_ char *label)
1185 register PERL_CONTEXT *cx;
1187 for (i = cxstack_ix; i >= 0; i--) {
1189 switch (CxTYPE(cx)) {
1191 if (ckWARN(WARN_EXITING))
1192 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1196 if (ckWARN(WARN_EXITING))
1197 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1201 if (ckWARN(WARN_EXITING))
1202 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1206 if (ckWARN(WARN_EXITING))
1207 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1216 if (!cx->blk_loop.label ||
1217 strNE(label, cx->blk_loop.label) ) {
1218 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1219 (long)i, cx->blk_loop.label));
1222 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1230 Perl_dowantarray(pTHX)
1232 I32 gimme = block_gimme();
1233 return (gimme == G_VOID) ? G_SCALAR : gimme;
1237 Perl_block_gimme(pTHX)
1241 cxix = dopoptosub(cxstack_ix);
1245 switch (cxstack[cxix].blk_gimme) {
1253 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1260 Perl_is_lvalue_sub(pTHX)
1264 cxix = dopoptosub(cxstack_ix);
1265 assert(cxix >= 0); /* We should only be called from inside subs */
1267 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1268 return cxstack[cxix].blk_sub.lval;
1274 S_dopoptosub(pTHX_ I32 startingblock)
1276 return dopoptosub_at(cxstack, startingblock);
1280 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1283 register PERL_CONTEXT *cx;
1284 for (i = startingblock; i >= 0; i--) {
1286 switch (CxTYPE(cx)) {
1292 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1300 S_dopoptoeval(pTHX_ I32 startingblock)
1303 register PERL_CONTEXT *cx;
1304 for (i = startingblock; i >= 0; i--) {
1306 switch (CxTYPE(cx)) {
1310 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1318 S_dopoptoloop(pTHX_ I32 startingblock)
1321 register PERL_CONTEXT *cx;
1322 for (i = startingblock; i >= 0; i--) {
1324 switch (CxTYPE(cx)) {
1326 if (ckWARN(WARN_EXITING))
1327 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1331 if (ckWARN(WARN_EXITING))
1332 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1336 if (ckWARN(WARN_EXITING))
1337 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1341 if (ckWARN(WARN_EXITING))
1342 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1346 if (ckWARN(WARN_EXITING))
1347 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1351 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1359 Perl_dounwind(pTHX_ I32 cxix)
1361 register PERL_CONTEXT *cx;
1364 while (cxstack_ix > cxix) {
1366 cx = &cxstack[cxstack_ix];
1367 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1368 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1369 /* Note: we don't need to restore the base context info till the end. */
1370 switch (CxTYPE(cx)) {
1373 continue; /* not break */
1395 Perl_qerror(pTHX_ SV *err)
1398 sv_catsv(ERRSV, err);
1400 sv_catsv(PL_errors, err);
1402 Perl_warn(aTHX_ "%"SVf, err);
1407 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1412 register PERL_CONTEXT *cx;
1417 if (PL_in_eval & EVAL_KEEPERR) {
1418 static char prefix[] = "\t(in cleanup) ";
1423 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1426 if (*e != *message || strNE(e,message))
1430 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1431 sv_catpvn(err, prefix, sizeof(prefix)-1);
1432 sv_catpvn(err, message, msglen);
1433 if (ckWARN(WARN_MISC)) {
1434 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1435 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1440 sv_setpvn(ERRSV, message, msglen);
1444 message = SvPVx(ERRSV, msglen);
1446 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1447 && PL_curstackinfo->si_prev)
1456 if (cxix < cxstack_ix)
1459 POPBLOCK(cx,PL_curpm);
1460 if (CxTYPE(cx) != CXt_EVAL) {
1461 PerlIO_write(Perl_error_log, "panic: die ", 11);
1462 PerlIO_write(Perl_error_log, message, msglen);
1467 if (gimme == G_SCALAR)
1468 *++newsp = &PL_sv_undef;
1469 PL_stack_sp = newsp;
1473 /* LEAVE could clobber PL_curcop (see save_re_context())
1474 * XXX it might be better to find a way to avoid messing with
1475 * PL_curcop in save_re_context() instead, but this is a more
1476 * minimal fix --GSAR */
1477 PL_curcop = cx->blk_oldcop;
1479 if (optype == OP_REQUIRE) {
1480 char* msg = SvPVx(ERRSV, n_a);
1481 DIE(aTHX_ "%sCompilation failed in require",
1482 *msg ? msg : "Unknown error\n");
1484 return pop_return();
1488 message = SvPVx(ERRSV, msglen);
1491 /* SFIO can really mess with your errno */
1494 PerlIO *serr = Perl_error_log;
1496 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1497 (void)PerlIO_flush(serr);
1510 if (SvTRUE(left) != SvTRUE(right))
1522 RETURNOP(cLOGOP->op_other);
1531 RETURNOP(cLOGOP->op_other);
1537 register I32 cxix = dopoptosub(cxstack_ix);
1538 register PERL_CONTEXT *cx;
1539 register PERL_CONTEXT *ccstack = cxstack;
1540 PERL_SI *top_si = PL_curstackinfo;
1551 /* we may be in a higher stacklevel, so dig down deeper */
1552 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1553 top_si = top_si->si_prev;
1554 ccstack = top_si->si_cxstack;
1555 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1558 if (GIMME != G_ARRAY) {
1564 if (PL_DBsub && cxix >= 0 &&
1565 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1569 cxix = dopoptosub_at(ccstack, cxix - 1);
1572 cx = &ccstack[cxix];
1573 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1574 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1575 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1576 field below is defined for any cx. */
1577 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1578 cx = &ccstack[dbcxix];
1581 stashname = CopSTASHPV(cx->blk_oldcop);
1582 if (GIMME != G_ARRAY) {
1585 PUSHs(&PL_sv_undef);
1588 sv_setpv(TARG, stashname);
1597 PUSHs(&PL_sv_undef);
1599 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1600 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1601 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1604 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1605 /* So is ccstack[dbcxix]. */
1607 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1608 PUSHs(sv_2mortal(sv));
1609 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1612 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1613 PUSHs(sv_2mortal(newSViv(0)));
1615 gimme = (I32)cx->blk_gimme;
1616 if (gimme == G_VOID)
1617 PUSHs(&PL_sv_undef);
1619 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1620 if (CxTYPE(cx) == CXt_EVAL) {
1622 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1623 PUSHs(cx->blk_eval.cur_text);
1627 else if (cx->blk_eval.old_namesv) {
1628 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1631 /* eval BLOCK (try blocks have old_namesv == 0) */
1633 PUSHs(&PL_sv_undef);
1634 PUSHs(&PL_sv_undef);
1638 PUSHs(&PL_sv_undef);
1639 PUSHs(&PL_sv_undef);
1641 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1642 && CopSTASH_eq(PL_curcop, PL_debstash))
1644 AV *ary = cx->blk_sub.argarray;
1645 int off = AvARRAY(ary) - AvALLOC(ary);
1649 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1652 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1655 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1656 av_extend(PL_dbargs, AvFILLp(ary) + off);
1657 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1658 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1660 /* XXX only hints propagated via op_private are currently
1661 * visible (others are not easily accessible, since they
1662 * use the global PL_hints) */
1663 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1664 HINT_PRIVATE_MASK)));
1667 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1669 if (old_warnings == pWARN_NONE ||
1670 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1671 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1672 else if (old_warnings == pWARN_ALL ||
1673 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1674 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1676 mask = newSVsv(old_warnings);
1677 PUSHs(sv_2mortal(mask));
1692 sv_reset(tmps, CopSTASH(PL_curcop));
1704 PL_curcop = (COP*)PL_op;
1705 TAINT_NOT; /* Each statement is presumed innocent */
1706 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1709 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1713 register PERL_CONTEXT *cx;
1714 I32 gimme = G_ARRAY;
1721 DIE(aTHX_ "No DB::DB routine defined");
1723 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1724 /* don't do recursive DB::DB call */
1736 push_return(PL_op->op_next);
1737 PUSHBLOCK(cx, CXt_SUB, SP);
1740 (void)SvREFCNT_inc(cv);
1741 SAVEVPTR(PL_curpad);
1742 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1743 RETURNOP(CvSTART(cv));
1757 register PERL_CONTEXT *cx;
1758 I32 gimme = GIMME_V;
1760 U32 cxtype = CXt_LOOP;
1768 #ifdef USE_5005THREADS
1769 if (PL_op->op_flags & OPf_SPECIAL) {
1770 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1771 SAVEGENERICSV(*svp);
1775 #endif /* USE_5005THREADS */
1776 if (PL_op->op_targ) {
1777 #ifndef USE_ITHREADS
1778 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1781 SAVEPADSV(PL_op->op_targ);
1782 iterdata = INT2PTR(void*, PL_op->op_targ);
1783 cxtype |= CXp_PADVAR;
1788 svp = &GvSV(gv); /* symbol table variable */
1789 SAVEGENERICSV(*svp);
1792 iterdata = (void*)gv;
1798 PUSHBLOCK(cx, cxtype, SP);
1800 PUSHLOOP(cx, iterdata, MARK);
1802 PUSHLOOP(cx, svp, MARK);
1804 if (PL_op->op_flags & OPf_STACKED) {
1805 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1806 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1808 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1809 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1810 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1811 looks_like_number((SV*)cx->blk_loop.iterary) &&
1812 *SvPVX(cx->blk_loop.iterary) != '0'))
1814 if (SvNV(sv) < IV_MIN ||
1815 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1816 DIE(aTHX_ "Range iterator outside integer range");
1817 cx->blk_loop.iterix = SvIV(sv);
1818 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1821 cx->blk_loop.iterlval = newSVsv(sv);
1825 cx->blk_loop.iterary = PL_curstack;
1826 AvFILLp(PL_curstack) = SP - PL_stack_base;
1827 cx->blk_loop.iterix = MARK - PL_stack_base;
1836 register PERL_CONTEXT *cx;
1837 I32 gimme = GIMME_V;
1843 PUSHBLOCK(cx, CXt_LOOP, SP);
1844 PUSHLOOP(cx, 0, SP);
1852 register PERL_CONTEXT *cx;
1860 newsp = PL_stack_base + cx->blk_loop.resetsp;
1863 if (gimme == G_VOID)
1865 else if (gimme == G_SCALAR) {
1867 *++newsp = sv_mortalcopy(*SP);
1869 *++newsp = &PL_sv_undef;
1873 *++newsp = sv_mortalcopy(*++mark);
1874 TAINT_NOT; /* Each item is independent */
1880 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1881 PL_curpm = newpm; /* ... and pop $1 et al */
1893 register PERL_CONTEXT *cx;
1894 bool popsub2 = FALSE;
1895 bool clear_errsv = FALSE;
1902 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1903 if (cxstack_ix == PL_sortcxix
1904 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1906 if (cxstack_ix > PL_sortcxix)
1907 dounwind(PL_sortcxix);
1908 AvARRAY(PL_curstack)[1] = *SP;
1909 PL_stack_sp = PL_stack_base + 1;
1914 cxix = dopoptosub(cxstack_ix);
1916 DIE(aTHX_ "Can't return outside a subroutine");
1917 if (cxix < cxstack_ix)
1921 switch (CxTYPE(cx)) {
1926 if (!(PL_in_eval & EVAL_KEEPERR))
1932 if (optype == OP_REQUIRE &&
1933 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1935 /* Unassume the success we assumed earlier. */
1936 SV *nsv = cx->blk_eval.old_namesv;
1937 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1938 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1945 DIE(aTHX_ "panic: return");
1949 if (gimme == G_SCALAR) {
1952 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1954 *++newsp = SvREFCNT_inc(*SP);
1959 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1961 *++newsp = sv_mortalcopy(sv);
1966 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1969 *++newsp = sv_mortalcopy(*SP);
1972 *++newsp = &PL_sv_undef;
1974 else if (gimme == G_ARRAY) {
1975 while (++MARK <= SP) {
1976 *++newsp = (popsub2 && SvTEMP(*MARK))
1977 ? *MARK : sv_mortalcopy(*MARK);
1978 TAINT_NOT; /* Each item is independent */
1981 PL_stack_sp = newsp;
1983 /* Stack values are safe: */
1985 POPSUB(cx,sv); /* release CV and @_ ... */
1989 PL_curpm = newpm; /* ... and pop $1 et al */
1995 return pop_return();
2002 register PERL_CONTEXT *cx;
2012 if (PL_op->op_flags & OPf_SPECIAL) {
2013 cxix = dopoptoloop(cxstack_ix);
2015 DIE(aTHX_ "Can't \"last\" outside a loop block");
2018 cxix = dopoptolabel(cPVOP->op_pv);
2020 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2022 if (cxix < cxstack_ix)
2027 switch (CxTYPE(cx)) {
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2031 nextop = cx->blk_loop.last_op->op_next;
2035 nextop = pop_return();
2039 nextop = pop_return();
2043 nextop = pop_return();
2046 DIE(aTHX_ "panic: last");
2050 if (gimme == G_SCALAR) {
2052 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2053 ? *SP : sv_mortalcopy(*SP);
2055 *++newsp = &PL_sv_undef;
2057 else if (gimme == G_ARRAY) {
2058 while (++MARK <= SP) {
2059 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2060 ? *MARK : sv_mortalcopy(*MARK);
2061 TAINT_NOT; /* Each item is independent */
2067 /* Stack values are safe: */
2070 POPLOOP(cx); /* release loop vars ... */
2074 POPSUB(cx,sv); /* release CV and @_ ... */
2077 PL_curpm = newpm; /* ... and pop $1 et al */
2087 register PERL_CONTEXT *cx;
2090 if (PL_op->op_flags & OPf_SPECIAL) {
2091 cxix = dopoptoloop(cxstack_ix);
2093 DIE(aTHX_ "Can't \"next\" outside a loop block");
2096 cxix = dopoptolabel(cPVOP->op_pv);
2098 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2100 if (cxix < cxstack_ix)
2103 /* clear off anything above the scope we're re-entering, but
2104 * save the rest until after a possible continue block */
2105 inner = PL_scopestack_ix;
2107 if (PL_scopestack_ix < inner)
2108 leave_scope(PL_scopestack[PL_scopestack_ix]);
2109 return cx->blk_loop.next_op;
2115 register PERL_CONTEXT *cx;
2118 if (PL_op->op_flags & OPf_SPECIAL) {
2119 cxix = dopoptoloop(cxstack_ix);
2121 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2124 cxix = dopoptolabel(cPVOP->op_pv);
2126 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2128 if (cxix < cxstack_ix)
2132 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2133 LEAVE_SCOPE(oldsave);
2134 return cx->blk_loop.redo_op;
2138 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2142 static char too_deep[] = "Target of goto is too deeply nested";
2145 Perl_croak(aTHX_ too_deep);
2146 if (o->op_type == OP_LEAVE ||
2147 o->op_type == OP_SCOPE ||
2148 o->op_type == OP_LEAVELOOP ||
2149 o->op_type == OP_LEAVETRY)
2151 *ops++ = cUNOPo->op_first;
2153 Perl_croak(aTHX_ too_deep);
2156 if (o->op_flags & OPf_KIDS) {
2157 /* First try all the kids at this level, since that's likeliest. */
2158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2159 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2160 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2163 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2164 if (kid == PL_lastgotoprobe)
2166 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2168 (ops[-1]->op_type != OP_NEXTSTATE &&
2169 ops[-1]->op_type != OP_DBSTATE)))
2171 if ((o = dofindlabel(kid, label, ops, oplimit)))
2190 register PERL_CONTEXT *cx;
2191 #define GOTO_DEPTH 64
2192 OP *enterops[GOTO_DEPTH];
2194 int do_dump = (PL_op->op_type == OP_DUMP);
2195 static char must_have_label[] = "goto must have label";
2198 if (PL_op->op_flags & OPf_STACKED) {
2202 /* This egregious kludge implements goto &subroutine */
2203 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2205 register PERL_CONTEXT *cx;
2206 CV* cv = (CV*)SvRV(sv);
2212 if (!CvROOT(cv) && !CvXSUB(cv)) {
2217 /* autoloaded stub? */
2218 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2220 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2221 GvNAMELEN(gv), FALSE);
2222 if (autogv && (cv = GvCV(autogv)))
2224 tmpstr = sv_newmortal();
2225 gv_efullname3(tmpstr, gv, Nullch);
2226 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2228 DIE(aTHX_ "Goto undefined subroutine");
2231 /* First do some returnish stuff. */
2232 cxix = dopoptosub(cxstack_ix);
2234 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2235 if (cxix < cxstack_ix)
2239 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2241 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2242 /* put @_ back onto stack */
2243 AV* av = cx->blk_sub.argarray;
2245 items = AvFILLp(av) + 1;
2247 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2248 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2249 PL_stack_sp += items;
2250 #ifndef USE_5005THREADS
2251 SvREFCNT_dec(GvAV(PL_defgv));
2252 GvAV(PL_defgv) = cx->blk_sub.savearray;
2253 #endif /* USE_5005THREADS */
2254 /* abandon @_ if it got reified */
2256 (void)sv_2mortal((SV*)av); /* delay until return */
2258 av_extend(av, items-1);
2259 AvFLAGS(av) = AVf_REIFY;
2260 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2263 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2265 #ifdef USE_5005THREADS
2266 av = (AV*)PL_curpad[0];
2268 av = GvAV(PL_defgv);
2270 items = AvFILLp(av) + 1;
2272 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2273 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2274 PL_stack_sp += items;
2276 if (CxTYPE(cx) == CXt_SUB &&
2277 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2278 SvREFCNT_dec(cx->blk_sub.cv);
2279 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2280 LEAVE_SCOPE(oldsave);
2282 /* Now do some callish stuff. */
2285 #ifdef PERL_XSUB_OLDSTYLE
2286 if (CvOLDSTYLE(cv)) {
2287 I32 (*fp3)(int,int,int);
2292 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2293 items = (*fp3)(CvXSUBANY(cv).any_i32,
2294 mark - PL_stack_base + 1,
2296 SP = PL_stack_base + items;
2299 #endif /* PERL_XSUB_OLDSTYLE */
2304 PL_stack_sp--; /* There is no cv arg. */
2305 /* Push a mark for the start of arglist */
2307 (void)(*CvXSUB(cv))(aTHX_ cv);
2308 /* Pop the current context like a decent sub should */
2309 POPBLOCK(cx, PL_curpm);
2310 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2313 return pop_return();
2316 AV* padlist = CvPADLIST(cv);
2317 SV** svp = AvARRAY(padlist);
2318 if (CxTYPE(cx) == CXt_EVAL) {
2319 PL_in_eval = cx->blk_eval.old_in_eval;
2320 PL_eval_root = cx->blk_eval.old_eval_root;
2321 cx->cx_type = CXt_SUB;
2322 cx->blk_sub.hasargs = 0;
2324 cx->blk_sub.cv = cv;
2325 cx->blk_sub.olddepth = CvDEPTH(cv);
2327 if (CvDEPTH(cv) < 2)
2328 (void)SvREFCNT_inc(cv);
2329 else { /* save temporaries on recursion? */
2330 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2331 sub_crush_depth(cv);
2332 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2333 AV *newpad = newAV();
2334 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2335 I32 ix = AvFILLp((AV*)svp[1]);
2336 I32 names_fill = AvFILLp((AV*)svp[0]);
2337 svp = AvARRAY(svp[0]);
2338 for ( ;ix > 0; ix--) {
2339 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2340 char *name = SvPVX(svp[ix]);
2341 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2344 /* outer lexical or anon code */
2345 av_store(newpad, ix,
2346 SvREFCNT_inc(oldpad[ix]) );
2348 else { /* our own lexical */
2350 av_store(newpad, ix, sv = (SV*)newAV());
2351 else if (*name == '%')
2352 av_store(newpad, ix, sv = (SV*)newHV());
2354 av_store(newpad, ix, sv = NEWSV(0,0));
2358 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2359 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2362 av_store(newpad, ix, sv = NEWSV(0,0));
2366 if (cx->blk_sub.hasargs) {
2369 av_store(newpad, 0, (SV*)av);
2370 AvFLAGS(av) = AVf_REIFY;
2372 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2373 AvFILLp(padlist) = CvDEPTH(cv);
2374 svp = AvARRAY(padlist);
2377 #ifdef USE_5005THREADS
2378 if (!cx->blk_sub.hasargs) {
2379 AV* av = (AV*)PL_curpad[0];
2381 items = AvFILLp(av) + 1;
2383 /* Mark is at the end of the stack. */
2385 Copy(AvARRAY(av), SP + 1, items, SV*);
2390 #endif /* USE_5005THREADS */
2391 SAVEVPTR(PL_curpad);
2392 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2393 #ifndef USE_5005THREADS
2394 if (cx->blk_sub.hasargs)
2395 #endif /* USE_5005THREADS */
2397 AV* av = (AV*)PL_curpad[0];
2400 #ifndef USE_5005THREADS
2401 cx->blk_sub.savearray = GvAV(PL_defgv);
2402 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2403 #endif /* USE_5005THREADS */
2404 cx->blk_sub.oldcurpad = PL_curpad;
2405 cx->blk_sub.argarray = av;
2408 if (items >= AvMAX(av) + 1) {
2410 if (AvARRAY(av) != ary) {
2411 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2412 SvPVX(av) = (char*)ary;
2414 if (items >= AvMAX(av) + 1) {
2415 AvMAX(av) = items - 1;
2416 Renew(ary,items+1,SV*);
2418 SvPVX(av) = (char*)ary;
2421 Copy(mark,AvARRAY(av),items,SV*);
2422 AvFILLp(av) = items - 1;
2423 assert(!AvREAL(av));
2430 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2432 * We do not care about using sv to call CV;
2433 * it's for informational purposes only.
2435 SV *sv = GvSV(PL_DBsub);
2438 if (PERLDB_SUB_NN) {
2439 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2442 gv_efullname3(sv, CvGV(cv), Nullch);
2445 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2446 PUSHMARK( PL_stack_sp );
2447 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2451 RETURNOP(CvSTART(cv));
2455 label = SvPV(sv,n_a);
2456 if (!(do_dump || *label))
2457 DIE(aTHX_ must_have_label);
2460 else if (PL_op->op_flags & OPf_SPECIAL) {
2462 DIE(aTHX_ must_have_label);
2465 label = cPVOP->op_pv;
2467 if (label && *label) {
2469 bool leaving_eval = FALSE;
2470 PERL_CONTEXT *last_eval_cx = 0;
2474 PL_lastgotoprobe = 0;
2476 for (ix = cxstack_ix; ix >= 0; ix--) {
2478 switch (CxTYPE(cx)) {
2480 leaving_eval = TRUE;
2481 if (CxREALEVAL(cx)) {
2482 gotoprobe = (last_eval_cx ?
2483 last_eval_cx->blk_eval.old_eval_root :
2488 /* else fall through */
2490 gotoprobe = cx->blk_oldcop->op_sibling;
2496 gotoprobe = cx->blk_oldcop->op_sibling;
2498 gotoprobe = PL_main_root;
2501 if (CvDEPTH(cx->blk_sub.cv)) {
2502 gotoprobe = CvROOT(cx->blk_sub.cv);
2508 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2511 DIE(aTHX_ "panic: goto");
2512 gotoprobe = PL_main_root;
2516 retop = dofindlabel(gotoprobe, label,
2517 enterops, enterops + GOTO_DEPTH);
2521 PL_lastgotoprobe = gotoprobe;
2524 DIE(aTHX_ "Can't find label %s", label);
2526 /* if we're leaving an eval, check before we pop any frames
2527 that we're not going to punt, otherwise the error
2530 if (leaving_eval && *enterops && enterops[1]) {
2532 for (i = 1; enterops[i]; i++)
2533 if (enterops[i]->op_type == OP_ENTERITER)
2534 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2537 /* pop unwanted frames */
2539 if (ix < cxstack_ix) {
2546 oldsave = PL_scopestack[PL_scopestack_ix];
2547 LEAVE_SCOPE(oldsave);
2550 /* push wanted frames */
2552 if (*enterops && enterops[1]) {
2554 for (ix = 1; enterops[ix]; ix++) {
2555 PL_op = enterops[ix];
2556 /* Eventually we may want to stack the needed arguments
2557 * for each op. For now, we punt on the hard ones. */
2558 if (PL_op->op_type == OP_ENTERITER)
2559 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2560 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2568 if (!retop) retop = PL_main_start;
2570 PL_restartop = retop;
2571 PL_do_undump = TRUE;
2575 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2576 PL_do_undump = FALSE;
2592 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2596 PL_exit_flags |= PERL_EXIT_EXPECTED;
2598 PUSHs(&PL_sv_undef);
2606 NV value = SvNVx(GvSV(cCOP->cop_gv));
2607 register I32 match = I_32(value);
2610 if (((NV)match) > value)
2611 --match; /* was fractional--truncate other way */
2613 match -= cCOP->uop.scop.scop_offset;
2616 else if (match > cCOP->uop.scop.scop_max)
2617 match = cCOP->uop.scop.scop_max;
2618 PL_op = cCOP->uop.scop.scop_next[match];
2628 PL_op = PL_op->op_next; /* can't assume anything */
2631 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2632 match -= cCOP->uop.scop.scop_offset;
2635 else if (match > cCOP->uop.scop.scop_max)
2636 match = cCOP->uop.scop.scop_max;
2637 PL_op = cCOP->uop.scop.scop_next[match];
2646 S_save_lines(pTHX_ AV *array, SV *sv)
2648 register char *s = SvPVX(sv);
2649 register char *send = SvPVX(sv) + SvCUR(sv);
2651 register I32 line = 1;
2653 while (s && s < send) {
2654 SV *tmpstr = NEWSV(85,0);
2656 sv_upgrade(tmpstr, SVt_PVMG);
2657 t = strchr(s, '\n');
2663 sv_setpvn(tmpstr, s, t - s);
2664 av_store(array, line++, tmpstr);
2669 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2671 S_docatch_body(pTHX_ va_list args)
2673 return docatch_body();
2678 S_docatch_body(pTHX)
2685 S_docatch(pTHX_ OP *o)
2689 volatile PERL_SI *cursi = PL_curstackinfo;
2693 assert(CATCH_GET == TRUE);
2696 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2698 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2704 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2710 if (PL_restartop && cursi == PL_curstackinfo) {
2711 PL_op = PL_restartop;
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2733 dSP; /* Make POPBLOCK work. */
2736 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2740 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741 char *tmpbuf = tbuf;
2747 /* switch to eval mode */
2749 if (PL_curcop == &PL_compiling) {
2750 SAVECOPSTASH_FREE(&PL_compiling);
2751 CopSTASH_set(&PL_compiling, PL_curstash);
2753 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2754 SV *sv = sv_newmortal();
2755 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2756 code, (unsigned long)++PL_evalseq,
2757 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2761 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2762 SAVECOPFILE_FREE(&PL_compiling);
2763 CopFILE_set(&PL_compiling, tmpbuf+2);
2764 SAVECOPLINE(&PL_compiling);
2765 CopLINE_set(&PL_compiling, 1);
2766 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2767 deleting the eval's FILEGV from the stash before gv_check() runs
2768 (i.e. before run-time proper). To work around the coredump that
2769 ensues, we always turn GvMULTI_on for any globals that were
2770 introduced within evals. See force_ident(). GSAR 96-10-12 */
2771 safestr = savepv(tmpbuf);
2772 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2774 #ifdef OP_IN_REGISTER
2779 PL_hints &= HINT_UTF8;
2782 PL_op->op_type = OP_ENTEREVAL;
2783 PL_op->op_flags = 0; /* Avoid uninit warning. */
2784 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2785 PUSHEVAL(cx, 0, Nullgv);
2786 rop = doeval(G_SCALAR, startop);
2787 POPBLOCK(cx,PL_curpm);
2790 (*startop)->op_type = OP_NULL;
2791 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2793 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2795 if (PL_curcop == &PL_compiling)
2796 PL_compiling.op_private = PL_hints;
2797 #ifdef OP_IN_REGISTER
2803 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2805 S_doeval(pTHX_ int gimme, OP** startop)
2813 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2814 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2819 /* set up a scratch pad */
2822 SAVEVPTR(PL_curpad);
2823 SAVESPTR(PL_comppad);
2824 SAVESPTR(PL_comppad_name);
2825 SAVEI32(PL_comppad_name_fill);
2826 SAVEI32(PL_min_intro_pending);
2827 SAVEI32(PL_max_intro_pending);
2830 for (i = cxstack_ix - 1; i >= 0; i--) {
2831 PERL_CONTEXT *cx = &cxstack[i];
2832 if (CxTYPE(cx) == CXt_EVAL)
2834 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2835 caller = cx->blk_sub.cv;
2840 SAVESPTR(PL_compcv);
2841 PL_compcv = (CV*)NEWSV(1104,0);
2842 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2843 CvEVAL_on(PL_compcv);
2844 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2845 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2847 #ifdef USE_5005THREADS
2848 CvOWNER(PL_compcv) = 0;
2849 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2850 MUTEX_INIT(CvMUTEXP(PL_compcv));
2851 #endif /* USE_5005THREADS */
2853 PL_comppad = newAV();
2854 av_push(PL_comppad, Nullsv);
2855 PL_curpad = AvARRAY(PL_comppad);
2856 PL_comppad_name = newAV();
2857 PL_comppad_name_fill = 0;
2858 PL_min_intro_pending = 0;
2860 #ifdef USE_5005THREADS
2861 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2862 PL_curpad[0] = (SV*)newAV();
2863 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2864 #endif /* USE_5005THREADS */
2866 comppadlist = newAV();
2867 AvREAL_off(comppadlist);
2868 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2869 av_store(comppadlist, 1, (SV*)PL_comppad);
2870 CvPADLIST(PL_compcv) = comppadlist;
2873 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2875 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2878 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2880 /* make sure we compile in the right package */
2882 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2883 SAVESPTR(PL_curstash);
2884 PL_curstash = CopSTASH(PL_curcop);
2886 SAVESPTR(PL_beginav);
2887 PL_beginav = newAV();
2888 SAVEFREESV(PL_beginav);
2889 SAVEI32(PL_error_count);
2891 /* try to compile it */
2893 PL_eval_root = Nullop;
2895 PL_curcop = &PL_compiling;
2896 PL_curcop->cop_arybase = 0;
2897 if (saveop && saveop->op_flags & OPf_SPECIAL)
2898 PL_in_eval |= EVAL_KEEPERR;
2901 if (yyparse() || PL_error_count || !PL_eval_root) {
2905 I32 optype = 0; /* Might be reset by POPEVAL. */
2910 op_free(PL_eval_root);
2911 PL_eval_root = Nullop;
2913 SP = PL_stack_base + POPMARK; /* pop original mark */
2915 POPBLOCK(cx,PL_curpm);
2921 if (optype == OP_REQUIRE) {
2922 char* msg = SvPVx(ERRSV, n_a);
2923 DIE(aTHX_ "%sCompilation failed in require",
2924 *msg ? msg : "Unknown error\n");
2927 char* msg = SvPVx(ERRSV, n_a);
2929 POPBLOCK(cx,PL_curpm);
2931 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2932 (*msg ? msg : "Unknown error\n"));
2934 #ifdef USE_5005THREADS
2935 MUTEX_LOCK(&PL_eval_mutex);
2937 COND_SIGNAL(&PL_eval_cond);
2938 MUTEX_UNLOCK(&PL_eval_mutex);
2939 #endif /* USE_5005THREADS */
2942 CopLINE_set(&PL_compiling, 0);
2944 *startop = PL_eval_root;
2945 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2946 CvOUTSIDE(PL_compcv) = Nullcv;
2948 SAVEFREEOP(PL_eval_root);
2950 scalarvoid(PL_eval_root);
2951 else if (gimme & G_ARRAY)
2954 scalar(PL_eval_root);
2956 DEBUG_x(dump_eval());
2958 /* Register with debugger: */
2959 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2960 CV *cv = get_cv("DB::postponed", FALSE);
2964 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2966 call_sv((SV*)cv, G_DISCARD);
2970 /* compiled okay, so do it */
2972 CvDEPTH(PL_compcv) = 1;
2973 SP = PL_stack_base + POPMARK; /* pop original mark */
2974 PL_op = saveop; /* The caller may need it. */
2975 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2976 #ifdef USE_5005THREADS
2977 MUTEX_LOCK(&PL_eval_mutex);
2979 COND_SIGNAL(&PL_eval_cond);
2980 MUTEX_UNLOCK(&PL_eval_mutex);
2981 #endif /* USE_5005THREADS */
2983 RETURNOP(PL_eval_start);
2987 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2989 STRLEN namelen = strlen(name);
2992 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2993 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2994 char *pmc = SvPV_nolen(pmcsv);
2997 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2998 fp = PerlIO_open(name, mode);
3001 if (PerlLIO_stat(name, &pmstat) < 0 ||
3002 pmstat.st_mtime < pmcstat.st_mtime)
3004 fp = PerlIO_open(pmc, mode);
3007 fp = PerlIO_open(name, mode);
3010 SvREFCNT_dec(pmcsv);
3013 fp = PerlIO_open(name, mode);
3021 register PERL_CONTEXT *cx;
3025 char *tryname = Nullch;
3026 SV *namesv = Nullsv;
3028 I32 gimme = GIMME_V;
3029 PerlIO *tryrsfp = 0;
3031 int filter_has_file = 0;
3032 GV *filter_child_proc = 0;
3033 SV *filter_state = 0;
3039 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3040 UV rev = 0, ver = 0, sver = 0;
3042 U8 *s = (U8*)SvPVX(sv);
3043 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3045 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3048 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3051 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3054 if (PERL_REVISION < rev
3055 || (PERL_REVISION == rev
3056 && (PERL_VERSION < ver
3057 || (PERL_VERSION == ver
3058 && PERL_SUBVERSION < sver))))
3060 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3061 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3062 PERL_VERSION, PERL_SUBVERSION);
3064 if (ckWARN(WARN_PORTABLE))
3065 Perl_warner(aTHX_ WARN_PORTABLE,
3066 "v-string in use/require non-portable");
3069 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3070 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3071 + ((NV)PERL_SUBVERSION/(NV)1000000)
3072 + 0.00000099 < SvNV(sv))
3076 NV nver = (nrev - rev) * 1000;
3077 UV ver = (UV)(nver + 0.0009);
3078 NV nsver = (nver - ver) * 1000;
3079 UV sver = (UV)(nsver + 0.0009);
3081 /* help out with the "use 5.6" confusion */
3082 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3083 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3084 "this is only v%d.%d.%d, stopped"
3085 " (did you mean v%"UVuf".%03"UVuf"?)",
3086 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3087 PERL_SUBVERSION, rev, ver/100);
3090 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3091 "this is only v%d.%d.%d, stopped",
3092 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3099 name = SvPV(sv, len);
3100 if (!(name && len > 0 && *name))
3101 DIE(aTHX_ "Null filename used");
3102 TAINT_PROPER("require");
3103 if (PL_op->op_type == OP_REQUIRE &&
3104 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3105 *svp != &PL_sv_undef)
3108 /* prepare to compile file */
3110 #ifdef MACOS_TRADITIONAL
3111 if (PERL_FILE_IS_ABSOLUTE(name)
3112 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3115 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3116 /* We consider paths of the form :a:b ambiguous and interpret them first
3117 as global then as local
3119 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3125 if (PERL_FILE_IS_ABSOLUTE(name)
3126 || (*name == '.' && (name[1] == '/' ||
3127 (name[1] == '.' && name[2] == '/'))))
3130 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3134 AV *ar = GvAVn(PL_incgv);
3138 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3141 namesv = NEWSV(806, 0);
3142 for (i = 0; i <= AvFILL(ar); i++) {
3143 SV *dirsv = *av_fetch(ar, i, TRUE);
3149 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3150 && !sv_isobject(loader))
3152 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3155 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3156 PTR2UV(SvRV(dirsv)), name);
3157 tryname = SvPVX(namesv);
3168 if (sv_isobject(loader))
3169 count = call_method("INC", G_ARRAY);
3171 count = call_sv(loader, G_ARRAY);
3181 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3185 if (SvTYPE(arg) == SVt_PVGV) {
3186 IO *io = GvIO((GV *)arg);
3191 tryrsfp = IoIFP(io);
3192 if (IoTYPE(io) == IoTYPE_PIPE) {
3193 /* reading from a child process doesn't
3194 nest -- when returning from reading
3195 the inner module, the outer one is
3196 unreadable (closed?) I've tried to
3197 save the gv to manage the lifespan of
3198 the pipe, but this didn't help. XXX */
3199 filter_child_proc = (GV *)arg;
3200 (void)SvREFCNT_inc(filter_child_proc);
3203 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3204 PerlIO_close(IoOFP(io));
3216 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3218 (void)SvREFCNT_inc(filter_sub);
3221 filter_state = SP[i];
3222 (void)SvREFCNT_inc(filter_state);
3226 tryrsfp = PerlIO_open("/dev/null",
3241 filter_has_file = 0;
3242 if (filter_child_proc) {
3243 SvREFCNT_dec(filter_child_proc);
3244 filter_child_proc = 0;
3247 SvREFCNT_dec(filter_state);
3251 SvREFCNT_dec(filter_sub);
3256 char *dir = SvPVx(dirsv, n_a);
3257 #ifdef MACOS_TRADITIONAL
3259 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3263 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3265 sv_setpv(namesv, unixdir);
3266 sv_catpv(namesv, unixname);
3268 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3271 TAINT_PROPER("require");
3272 tryname = SvPVX(namesv);
3273 #ifdef MACOS_TRADITIONAL
3275 /* Convert slashes in the name part, but not the directory part, to colons */
3277 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3281 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3283 if (tryname[0] == '.' && tryname[1] == '/')
3291 SAVECOPFILE_FREE(&PL_compiling);
3292 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3293 SvREFCNT_dec(namesv);
3295 if (PL_op->op_type == OP_REQUIRE) {
3296 char *msgstr = name;
3297 if (namesv) { /* did we lookup @INC? */
3298 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3299 SV *dirmsgsv = NEWSV(0, 0);
3300 AV *ar = GvAVn(PL_incgv);
3302 sv_catpvn(msg, " in @INC", 8);
3303 if (instr(SvPVX(msg), ".h "))
3304 sv_catpv(msg, " (change .h to .ph maybe?)");
3305 if (instr(SvPVX(msg), ".ph "))
3306 sv_catpv(msg, " (did you run h2ph?)");
3307 sv_catpv(msg, " (@INC contains:");
3308 for (i = 0; i <= AvFILL(ar); i++) {
3309 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3310 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3311 sv_catsv(msg, dirmsgsv);
3313 sv_catpvn(msg, ")", 1);
3314 SvREFCNT_dec(dirmsgsv);
3315 msgstr = SvPV_nolen(msg);
3317 DIE(aTHX_ "Can't locate %s", msgstr);
3323 SETERRNO(0, SS$_NORMAL);
3325 /* Assume success here to prevent recursive requirement. */
3327 /* Check whether a hook in @INC has already filled %INC */
3328 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3329 (void)hv_store(GvHVn(PL_incgv), name, len,
3330 (hook_sv ? SvREFCNT_inc(hook_sv)
3331 : newSVpv(CopFILE(&PL_compiling), 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>
3820 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3821 #define Safefree(VAR) free(VAR)
3822 typedef int (*SVCOMPARE_t) (pTHX_ SV*, SV*);
3823 #endif /* TESTHARNESS */
3825 typedef char * aptr; /* pointer for arithmetic on sizes */
3826 typedef SV * gptr; /* pointers in our lists */
3828 /* Binary merge internal sort, with a few special mods
3829 ** for the special perl environment it now finds itself in.
3831 ** Things that were once options have been hotwired
3832 ** to values suitable for this use. In particular, we'll always
3833 ** initialize looking for natural runs, we'll always produce stable
3834 ** output, and we'll always do Peter McIlroy's binary merge.
3837 /* Pointer types for arithmetic and storage and convenience casts */
3839 #define APTR(P) ((aptr)(P))
3840 #define GPTP(P) ((gptr *)(P))
3841 #define GPPP(P) ((gptr **)(P))
3844 /* byte offset from pointer P to (larger) pointer Q */
3845 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3847 #define PSIZE sizeof(gptr)
3849 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3852 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3853 #define PNBYTE(N) ((N) << (PSHIFT))
3854 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3856 /* Leave optimization to compiler */
3857 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3858 #define PNBYTE(N) ((N) * (PSIZE))
3859 #define PINDEX(P, N) (GPTP(P) + (N))
3862 /* Pointer into other corresponding to pointer into this */
3863 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3865 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3868 /* Runs are identified by a pointer in the auxilliary list.
3869 ** The pointer is at the start of the list,
3870 ** and it points to the start of the next list.
3871 ** NEXT is used as an lvalue, too.
3874 #define NEXT(P) (*GPPP(P))
3877 /* PTHRESH is the minimum number of pairs with the same sense to justify
3878 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3879 ** not just elements, so PTHRESH == 8 means a run of 16.
3884 /* RTHRESH is the number of elements in a run that must compare low
3885 ** to the low element from the opposing run before we justify
3886 ** doing a binary rampup instead of single stepping.
3887 ** In random input, N in a row low should only happen with
3888 ** probability 2^(1-N), so we can risk that we are dealing
3889 ** with orderly input without paying much when we aren't.
3896 ** Overview of algorithm and variables.
3897 ** The array of elements at list1 will be organized into runs of length 2,
3898 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3899 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3901 ** Unless otherwise specified, pair pointers address the first of two elements.
3903 ** b and b+1 are a pair that compare with sense ``sense''.
3904 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3906 ** p2 parallels b in the list2 array, where runs are defined by
3909 ** t represents the ``top'' of the adjacent pairs that might extend
3910 ** the run beginning at b. Usually, t addresses a pair
3911 ** that compares with opposite sense from (b,b+1).
3912 ** However, it may also address a singleton element at the end of list1,
3913 ** or it may be equal to ``last'', the first element beyond list1.
3915 ** r addresses the Nth pair following b. If this would be beyond t,
3916 ** we back it off to t. Only when r is less than t do we consider the
3917 ** run long enough to consider checking.
3919 ** q addresses a pair such that the pairs at b through q already form a run.
3920 ** Often, q will equal b, indicating we only are sure of the pair itself.
3921 ** However, a search on the previous cycle may have revealed a longer run,
3922 ** so q may be greater than b.
3924 ** p is used to work back from a candidate r, trying to reach q,
3925 ** which would mean b through r would be a run. If we discover such a run,
3926 ** we start q at r and try to push it further towards t.
3927 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3928 ** In any event, after the check (if any), we have two main cases.
3930 ** 1) Short run. b <= q < p <= r <= t.
3931 ** b through q is a run (perhaps trivial)
3932 ** q through p are uninteresting pairs
3933 ** p through r is a run
3935 ** 2) Long run. b < r <= q < t.
3936 ** b through q is a run (of length >= 2 * PTHRESH)
3938 ** Note that degenerate cases are not only possible, but likely.
3939 ** For example, if the pair following b compares with opposite sense,
3940 ** then b == q < p == r == t.
3945 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3948 register gptr *b, *p, *q, *t, *p2;
3949 register gptr c, *last, *r;
3953 last = PINDEX(b, nmemb);
3954 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3955 for (p2 = list2; b < last; ) {
3956 /* We just started, or just reversed sense.
3957 ** Set t at end of pairs with the prevailing sense.
3959 for (p = b+2, t = p; ++p < last; t = ++p) {
3960 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3963 /* Having laid out the playing field, look for long runs */
3965 p = r = b + (2 * PTHRESH);
3966 if (r >= t) p = r = t; /* too short to care about */
3968 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3971 /* b through r is a (long) run.
3972 ** Extend it as far as possible.
3975 while (((p += 2) < t) &&
3976 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3977 r = p = q + 2; /* no simple pairs, no after-run */
3980 if (q > b) { /* run of greater than 2 at b */
3983 /* pick up singleton, if possible */
3985 ((t + 1) == last) &&
3986 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3987 savep = r = p = q = last;
3988 p2 = NEXT(p2) = p2 + (p - b);
3989 if (sense) while (b < --p) {
3996 while (q < p) { /* simple pairs */
3997 p2 = NEXT(p2) = p2 + 2;
4004 if (((b = p) == t) && ((t+1) == last)) {
4016 /* Overview of bmerge variables:
4018 ** list1 and list2 address the main and auxiliary arrays.
4019 ** They swap identities after each merge pass.
4020 ** Base points to the original list1, so we can tell if
4021 ** the pointers ended up where they belonged (or must be copied).
4023 ** When we are merging two lists, f1 and f2 are the next elements
4024 ** on the respective lists. l1 and l2 mark the end of the lists.
4025 ** tp2 is the current location in the merged list.
4027 ** p1 records where f1 started.
4028 ** After the merge, a new descriptor is built there.
4030 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4031 ** It is used to identify and delimit the runs.
4033 ** In the heat of determining where q, the greater of the f1/f2 elements,
4034 ** belongs in the other list, b, t and p, represent bottom, top and probe
4035 ** locations, respectively, in the other list.
4036 ** They make convenient temporary pointers in other places.
4042 Sort an array. Here is an example:
4044 sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
4050 Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4054 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4055 gptr *aux, *list2, *p2, *last;
4059 if (nmemb <= 1) return; /* sorted trivially */
4060 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4062 dynprep(aTHX_ list1, list2, nmemb, cmp);
4063 last = PINDEX(list2, nmemb);
4064 while (NEXT(list2) != last) {
4065 /* More than one run remains. Do some merging to reduce runs. */
4067 for (tp2 = p2 = list2; p2 != last;) {
4068 /* The new first run begins where the old second list ended.
4069 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4073 f2 = l1 = POTHER(t, list2, list1);
4074 if (t != last) t = NEXT(t);
4075 l2 = POTHER(t, list2, list1);
4077 while (f1 < l1 && f2 < l2) {
4078 /* If head 1 is larger than head 2, find ALL the elements
4079 ** in list 2 strictly less than head1, write them all,
4080 ** then head 1. Then compare the new heads, and repeat,
4081 ** until one or both lists are exhausted.
4083 ** In all comparisons (after establishing
4084 ** which head to merge) the item to merge
4085 ** (at pointer q) is the first operand of
4086 ** the comparison. When we want to know
4087 ** if ``q is strictly less than the other'',
4089 ** cmp(q, other) < 0
4090 ** because stability demands that we treat equality
4091 ** as high when q comes from l2, and as low when
4092 ** q was from l1. So we ask the question by doing
4093 ** cmp(q, other) <= sense
4094 ** and make sense == 0 when equality should look low,
4095 ** and -1 when equality should look high.
4099 if (cmp(aTHX_ *f1, *f2) <= 0) {
4100 q = f2; b = f1; t = l1;
4103 q = f1; b = f2; t = l2;
4110 ** Leave t at something strictly
4111 ** greater than q (or at the end of the list),
4112 ** and b at something strictly less than q.
4114 for (i = 1, run = 0 ;;) {
4115 if ((p = PINDEX(b, i)) >= t) {
4117 if (((p = PINDEX(t, -1)) > b) &&
4118 (cmp(aTHX_ *q, *p) <= sense))
4122 } else if (cmp(aTHX_ *q, *p) <= sense) {
4126 if (++run >= RTHRESH) i += i;
4130 /* q is known to follow b and must be inserted before t.
4131 ** Increment b, so the range of possibilities is [b,t).
4132 ** Round binary split down, to favor early appearance.
4133 ** Adjust b and t until q belongs just before t.
4138 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4139 if (cmp(aTHX_ *q, *p) <= sense) {
4145 /* Copy all the strictly low elements */
4148 FROMTOUPTO(f2, tp2, t);
4151 FROMTOUPTO(f1, tp2, t);
4157 /* Run out remaining list */
4159 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4160 } else FROMTOUPTO(f1, tp2, l1);
4161 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4166 last = PINDEX(list2, nmemb);
4168 if (base == list2) {
4169 last = PINDEX(list1, nmemb);
4170 FROMTOUPTO(list1, list2, last);
4177 sortcv(pTHX_ SV *a, SV *b)
4179 I32 oldsaveix = PL_savestack_ix;
4180 I32 oldscopeix = PL_scopestack_ix;
4182 GvSV(PL_firstgv) = a;
4183 GvSV(PL_secondgv) = b;
4184 PL_stack_sp = PL_stack_base;
4187 if (PL_stack_sp != PL_stack_base + 1)
4188 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4189 if (!SvNIOKp(*PL_stack_sp))
4190 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4191 result = SvIV(*PL_stack_sp);
4192 while (PL_scopestack_ix > oldscopeix) {
4195 leave_scope(oldsaveix);
4200 sortcv_stacked(pTHX_ SV *a, SV *b)
4202 I32 oldsaveix = PL_savestack_ix;
4203 I32 oldscopeix = PL_scopestack_ix;
4207 #ifdef USE_5005THREADS
4208 av = (AV*)PL_curpad[0];
4210 av = GvAV(PL_defgv);
4213 if (AvMAX(av) < 1) {
4214 SV** ary = AvALLOC(av);
4215 if (AvARRAY(av) != ary) {
4216 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4217 SvPVX(av) = (char*)ary;
4219 if (AvMAX(av) < 1) {
4222 SvPVX(av) = (char*)ary;
4229 PL_stack_sp = PL_stack_base;
4232 if (PL_stack_sp != PL_stack_base + 1)
4233 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4234 if (!SvNIOKp(*PL_stack_sp))
4235 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4236 result = SvIV(*PL_stack_sp);
4237 while (PL_scopestack_ix > oldscopeix) {
4240 leave_scope(oldsaveix);
4245 sortcv_xsub(pTHX_ SV *a, SV *b)
4248 I32 oldsaveix = PL_savestack_ix;
4249 I32 oldscopeix = PL_scopestack_ix;
4251 CV *cv=(CV*)PL_sortcop;
4259 (void)(*CvXSUB(cv))(aTHX_ cv);
4260 if (PL_stack_sp != PL_stack_base + 1)
4261 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4262 if (!SvNIOKp(*PL_stack_sp))
4263 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4264 result = SvIV(*PL_stack_sp);
4265 while (PL_scopestack_ix > oldscopeix) {
4268 leave_scope(oldsaveix);
4274 sv_ncmp(pTHX_ SV *a, SV *b)
4278 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4282 sv_i_ncmp(pTHX_ SV *a, SV *b)
4286 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4288 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4290 if (PL_amagic_generation) { \
4291 if (SvAMAGIC(left)||SvAMAGIC(right))\
4292 *svp = amagic_call(left, \
4300 amagic_ncmp(pTHX_ register SV *a, register SV *b)
4303 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4308 I32 i = SvIVX(tmpsv);
4318 return sv_ncmp(aTHX_ a, b);
4322 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
4325 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4330 I32 i = SvIVX(tmpsv);
4340 return sv_i_ncmp(aTHX_ a, b);
4344 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
4347 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4352 I32 i = SvIVX(tmpsv);
4362 return sv_cmp(str1, str2);
4366 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
4369 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4374 I32 i = SvIVX(tmpsv);
4384 return sv_cmp_locale(str1, str2);
4388 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4390 SV *datasv = FILTER_DATA(idx);
4391 int filter_has_file = IoLINES(datasv);
4392 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4393 SV *filter_state = (SV *)IoTOP_GV(datasv);
4394 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4397 /* I was having segfault trouble under Linux 2.2.5 after a
4398 parse error occured. (Had to hack around it with a test
4399 for PL_error_count == 0.) Solaris doesn't segfault --
4400 not sure where the trouble is yet. XXX */
4402 if (filter_has_file) {
4403 len = FILTER_READ(idx+1, buf_sv, maxlen);
4406 if (filter_sub && len >= 0) {
4417 PUSHs(sv_2mortal(newSViv(maxlen)));
4419 PUSHs(filter_state);
4422 count = call_sv(filter_sub, G_SCALAR);
4438 IoLINES(datasv) = 0;
4439 if (filter_child_proc) {
4440 SvREFCNT_dec(filter_child_proc);
4441 IoFMT_GV(datasv) = Nullgv;
4444 SvREFCNT_dec(filter_state);
4445 IoTOP_GV(datasv) = Nullgv;
4448 SvREFCNT_dec(filter_sub);
4449 IoBOTTOM_GV(datasv) = Nullgv;
4451 filter_del(run_user_filter);