3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 sortcv(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 /* prevent recompiling under /o and ithreads. */
93 #if defined(USE_ITHREADS) || defined(USE_THREADS)
94 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
99 SV *sv = SvRV(tmpstr);
101 mg = mg_find(sv, PERL_MAGIC_qr);
104 regexp *re = (regexp *)mg->mg_obj;
105 ReREFCNT_dec(pm->op_pmregexp);
106 pm->op_pmregexp = ReREFCNT_inc(re);
109 t = SvPV(tmpstr, len);
111 /* Check against the last compiled regexp. */
112 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
113 pm->op_pmregexp->prelen != len ||
114 memNE(pm->op_pmregexp->precomp, t, len))
116 if (pm->op_pmregexp) {
117 ReREFCNT_dec(pm->op_pmregexp);
118 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
120 if (PL_op->op_flags & OPf_SPECIAL)
121 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
123 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
125 pm->op_pmdynflags |= PMdf_DYN_UTF8;
127 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
128 if (pm->op_pmdynflags & PMdf_UTF8)
129 t = (char*)bytes_to_utf8((U8*)t, &len);
131 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
132 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
134 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
135 inside tie/overload accessors. */
139 #ifndef INCOMPLETE_TAINTS
142 pm->op_pmdynflags |= PMdf_TAINTED;
144 pm->op_pmdynflags &= ~PMdf_TAINTED;
148 if (!pm->op_pmregexp->prelen && PL_curpm)
150 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
151 pm->op_pmflags |= PMf_WHITE;
153 /* XXX runtime compiled output needs to move to the pad */
154 if (pm->op_pmflags & PMf_KEEP) {
155 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
156 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
157 /* XXX can't change the optree at runtime either */
158 cLOGOP->op_first->op_next = PL_op->op_next;
167 register PMOP *pm = (PMOP*) cLOGOP->op_other;
168 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
169 register SV *dstr = cx->sb_dstr;
170 register char *s = cx->sb_s;
171 register char *m = cx->sb_m;
172 char *orig = cx->sb_orig;
173 register REGEXP *rx = cx->sb_rx;
175 rxres_restore(&cx->sb_rxres, rx);
177 if (cx->sb_iters++) {
178 if (cx->sb_iters > cx->sb_maxiters)
179 DIE(aTHX_ "Substitution loop");
181 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
182 cx->sb_rxtainted |= 2;
183 sv_catsv(dstr, POPs);
186 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
187 s == m, cx->sb_targ, NULL,
188 ((cx->sb_rflags & REXEC_COPY_STR)
189 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
190 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
192 SV *targ = cx->sb_targ;
194 sv_catpvn(dstr, s, cx->sb_strend - s);
195 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
197 (void)SvOOK_off(targ);
198 Safefree(SvPVX(targ));
199 SvPVX(targ) = SvPVX(dstr);
200 SvCUR_set(targ, SvCUR(dstr));
201 SvLEN_set(targ, SvLEN(dstr));
207 TAINT_IF(cx->sb_rxtainted & 1);
208 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
210 (void)SvPOK_only_UTF8(targ);
211 TAINT_IF(cx->sb_rxtainted);
215 LEAVE_SCOPE(cx->sb_oldsave);
217 RETURNOP(pm->op_next);
220 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
223 cx->sb_orig = orig = rx->subbeg;
225 cx->sb_strend = s + (cx->sb_strend - m);
227 cx->sb_m = m = rx->startp[0] + orig;
229 sv_catpvn(dstr, s, m-s);
230 cx->sb_s = rx->endp[0] + orig;
231 { /* Update the pos() information. */
232 SV *sv = cx->sb_targ;
235 if (SvTYPE(sv) < SVt_PVMG)
236 (void)SvUPGRADE(sv, SVt_PVMG);
237 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
238 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
239 mg = mg_find(sv, PERL_MAGIC_regex_global);
246 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
247 rxres_save(&cx->sb_rxres, rx);
248 RETURNOP(pm->op_pmreplstart);
252 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
257 if (!p || p[1] < rx->nparens) {
258 i = 6 + rx->nparens * 2;
266 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
267 RX_MATCH_COPIED_off(rx);
271 *p++ = PTR2UV(rx->subbeg);
272 *p++ = (UV)rx->sublen;
273 for (i = 0; i <= rx->nparens; ++i) {
274 *p++ = (UV)rx->startp[i];
275 *p++ = (UV)rx->endp[i];
280 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
285 if (RX_MATCH_COPIED(rx))
286 Safefree(rx->subbeg);
287 RX_MATCH_COPIED_set(rx, *p);
292 rx->subbeg = INT2PTR(char*,*p++);
293 rx->sublen = (I32)(*p++);
294 for (i = 0; i <= rx->nparens; ++i) {
295 rx->startp[i] = (I32)(*p++);
296 rx->endp[i] = (I32)(*p++);
301 Perl_rxres_free(pTHX_ void **rsp)
306 Safefree(INT2PTR(char*,*p));
314 dSP; dMARK; dORIGMARK;
315 register SV *tmpForm = *++MARK;
322 register SV *sv = Nullsv;
327 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
328 char *chophere = Nullch;
329 char *linemark = Nullch;
331 bool gotsome = FALSE;
333 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
334 bool item_is_utf = FALSE;
336 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
337 if (SvREADONLY(tmpForm)) {
338 SvREADONLY_off(tmpForm);
339 doparseform(tmpForm);
340 SvREADONLY_on(tmpForm);
343 doparseform(tmpForm);
346 SvPV_force(PL_formtarget, len);
347 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
349 f = SvPV(tmpForm, len);
350 /* need to jump to the next word */
351 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
360 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
361 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
362 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
363 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
364 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
366 case FF_CHECKNL: name = "CHECKNL"; break;
367 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
368 case FF_SPACE: name = "SPACE"; break;
369 case FF_HALFSPACE: name = "HALFSPACE"; break;
370 case FF_ITEM: name = "ITEM"; break;
371 case FF_CHOP: name = "CHOP"; break;
372 case FF_LINEGLOB: name = "LINEGLOB"; break;
373 case FF_NEWLINE: name = "NEWLINE"; break;
374 case FF_MORE: name = "MORE"; break;
375 case FF_LINEMARK: name = "LINEMARK"; break;
376 case FF_END: name = "END"; break;
377 case FF_0DECIMAL: name = "0DECIMAL"; break;
380 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
382 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
410 if (ckWARN(WARN_SYNTAX))
411 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
416 item = s = SvPV(sv, len);
419 itemsize = sv_len_utf8(sv);
420 if (itemsize != len) {
422 if (itemsize > fieldsize) {
423 itemsize = fieldsize;
424 itembytes = itemsize;
425 sv_pos_u2b(sv, &itembytes, 0);
429 send = chophere = s + itembytes;
439 sv_pos_b2u(sv, &itemsize);
444 if (itemsize > fieldsize)
445 itemsize = fieldsize;
446 send = chophere = s + itemsize;
458 item = s = SvPV(sv, len);
461 itemsize = sv_len_utf8(sv);
462 if (itemsize != len) {
464 if (itemsize <= fieldsize) {
465 send = chophere = s + itemsize;
476 itemsize = fieldsize;
477 itembytes = itemsize;
478 sv_pos_u2b(sv, &itembytes, 0);
479 send = chophere = s + itembytes;
480 while (s < send || (s == send && isSPACE(*s))) {
490 if (strchr(PL_chopset, *s))
495 itemsize = chophere - item;
496 sv_pos_b2u(sv, &itemsize);
503 if (itemsize <= fieldsize) {
504 send = chophere = s + itemsize;
515 itemsize = fieldsize;
516 send = chophere = s + itemsize;
517 while (s < send || (s == send && isSPACE(*s))) {
527 if (strchr(PL_chopset, *s))
532 itemsize = chophere - item;
537 arg = fieldsize - itemsize;
546 arg = fieldsize - itemsize;
560 if (UTF8_IS_CONTINUED(*s)) {
561 STRLEN skip = UTF8SKIP(s);
578 if ( !((*t++ = *s++) & ~31) )
586 int ch = *t++ = *s++;
589 if ( !((*t++ = *s++) & ~31) )
598 while (*s && isSPACE(*s))
605 item = s = SvPV(sv, len);
607 item_is_utf = FALSE; /* XXX is this correct? */
619 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
620 sv_catpvn(PL_formtarget, item, itemsize);
621 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
622 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
627 /* If the field is marked with ^ and the value is undefined,
630 if ((arg & 512) && !SvOK(sv)) {
638 /* Formats aren't yet marked for locales, so assume "yes". */
640 STORE_NUMERIC_STANDARD_SET_LOCAL();
641 #if defined(USE_LONG_DOUBLE)
643 sprintf(t, "%#*.*" PERL_PRIfldbl,
644 (int) fieldsize, (int) arg & 255, value);
646 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
651 (int) fieldsize, (int) arg & 255, value);
654 (int) fieldsize, value);
657 RESTORE_NUMERIC_STANDARD();
663 /* If the field is marked with ^ and the value is undefined,
666 if ((arg & 512) && !SvOK(sv)) {
674 /* Formats aren't yet marked for locales, so assume "yes". */
676 STORE_NUMERIC_STANDARD_SET_LOCAL();
677 #if defined(USE_LONG_DOUBLE)
679 sprintf(t, "%#0*.*" PERL_PRIfldbl,
680 (int) fieldsize, (int) arg & 255, value);
681 /* is this legal? I don't have long doubles */
683 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
687 sprintf(t, "%#0*.*f",
688 (int) fieldsize, (int) arg & 255, value);
691 (int) fieldsize, value);
694 RESTORE_NUMERIC_STANDARD();
701 while (t-- > linemark && *t == ' ') ;
709 if (arg) { /* repeat until fields exhausted? */
711 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
712 lines += FmLINES(PL_formtarget);
715 if (strnEQ(linemark, linemark - arg, arg))
716 DIE(aTHX_ "Runaway format");
718 FmLINES(PL_formtarget) = lines;
720 RETURNOP(cLISTOP->op_first);
733 while (*s && isSPACE(*s) && s < send)
737 arg = fieldsize - itemsize;
744 if (strnEQ(s," ",3)) {
745 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
756 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
757 FmLINES(PL_formtarget) += lines;
769 if (PL_stack_base + *PL_markstack_ptr == SP) {
771 if (GIMME_V == G_SCALAR)
772 XPUSHs(sv_2mortal(newSViv(0)));
773 RETURNOP(PL_op->op_next->op_next);
775 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
776 pp_pushmark(); /* push dst */
777 pp_pushmark(); /* push src */
778 ENTER; /* enter outer scope */
781 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
783 ENTER; /* enter inner scope */
786 src = PL_stack_base[*PL_markstack_ptr];
791 if (PL_op->op_type == OP_MAPSTART)
792 pp_pushmark(); /* push top */
793 return ((LOGOP*)PL_op->op_next)->op_other;
798 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
804 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
810 /* first, move source pointer to the next item in the source list */
811 ++PL_markstack_ptr[-1];
813 /* if there are new items, push them into the destination list */
815 /* might need to make room back there first */
816 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
817 /* XXX this implementation is very pessimal because the stack
818 * is repeatedly extended for every set of items. Is possible
819 * to do this without any stack extension or copying at all
820 * by maintaining a separate list over which the map iterates
821 * (like foreach does). --gsar */
823 /* everything in the stack after the destination list moves
824 * towards the end the stack by the amount of room needed */
825 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
827 /* items to shift up (accounting for the moved source pointer) */
828 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
830 /* This optimization is by Ben Tilly and it does
831 * things differently from what Sarathy (gsar)
832 * is describing. The downside of this optimization is
833 * that leaves "holes" (uninitialized and hopefully unused areas)
834 * to the Perl stack, but on the other hand this
835 * shouldn't be a problem. If Sarathy's idea gets
836 * implemented, this optimization should become
837 * irrelevant. --jhi */
839 shift = count; /* Avoid shifting too often --Ben Tilly */
844 PL_markstack_ptr[-1] += shift;
845 *PL_markstack_ptr += shift;
849 /* copy the new items down to the destination list */
850 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
852 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
854 LEAVE; /* exit inner scope */
857 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
860 (void)POPMARK; /* pop top */
861 LEAVE; /* exit outer scope */
862 (void)POPMARK; /* pop src */
863 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
864 (void)POPMARK; /* pop dst */
865 SP = PL_stack_base + POPMARK; /* pop original mark */
866 if (gimme == G_SCALAR) {
870 else if (gimme == G_ARRAY)
877 ENTER; /* enter inner scope */
880 /* set $_ to the new source item */
881 src = PL_stack_base[PL_markstack_ptr[-1]];
885 RETURNOP(cLOGOP->op_other);
891 dSP; dMARK; dORIGMARK;
893 SV **myorigmark = ORIGMARK;
899 OP* nextop = PL_op->op_next;
901 bool hasargs = FALSE;
904 if (gimme != G_ARRAY) {
910 SAVEVPTR(PL_sortcop);
911 if (PL_op->op_flags & OPf_STACKED) {
912 if (PL_op->op_flags & OPf_SPECIAL) {
913 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
914 kid = kUNOP->op_first; /* pass rv2gv */
915 kid = kUNOP->op_first; /* pass leave */
916 PL_sortcop = kid->op_next;
917 stash = CopSTASH(PL_curcop);
920 cv = sv_2cv(*++MARK, &stash, &gv, 0);
921 if (cv && SvPOK(cv)) {
923 char *proto = SvPV((SV*)cv, n_a);
924 if (proto && strEQ(proto, "$$")) {
928 if (!(cv && CvROOT(cv))) {
929 if (cv && CvXSUB(cv)) {
933 SV *tmpstr = sv_newmortal();
934 gv_efullname3(tmpstr, gv, Nullch);
935 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
939 DIE(aTHX_ "Undefined subroutine in sort");
944 PL_sortcop = (OP*)cv;
946 PL_sortcop = CvSTART(cv);
947 SAVEVPTR(CvROOT(cv)->op_ppaddr);
948 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
951 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
957 stash = CopSTASH(PL_curcop);
961 while (MARK < SP) { /* This may or may not shift down one here. */
963 if ((*up = *++MARK)) { /* Weed out nulls. */
965 if (!PL_sortcop && !SvPOK(*up)) {
970 (void)sv_2pv(*up, &n_a);
975 max = --up - myorigmark;
980 bool oldcatch = CATCH_GET;
986 PUSHSTACKi(PERLSI_SORT);
987 if (!hasargs && !is_xsub) {
988 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
989 SAVESPTR(PL_firstgv);
990 SAVESPTR(PL_secondgv);
991 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
992 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
993 PL_sortstash = stash;
996 sv_lock((SV *)PL_firstgv);
997 sv_lock((SV *)PL_secondgv);
999 SAVESPTR(GvSV(PL_firstgv));
1000 SAVESPTR(GvSV(PL_secondgv));
1003 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
1004 if (!(PL_op->op_flags & OPf_SPECIAL)) {
1005 cx->cx_type = CXt_SUB;
1006 cx->blk_gimme = G_SCALAR;
1009 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1011 PL_sortcxix = cxstack_ix;
1013 if (hasargs && !is_xsub) {
1014 /* This is mostly copied from pp_entersub */
1015 AV *av = (AV*)PL_curpad[0];
1018 cx->blk_sub.savearray = GvAV(PL_defgv);
1019 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1020 #endif /* USE_THREADS */
1021 cx->blk_sub.oldcurpad = PL_curpad;
1022 cx->blk_sub.argarray = av;
1024 qsortsv((myorigmark+1), max,
1025 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1027 POPBLOCK(cx,PL_curpm);
1028 PL_stack_sp = newsp;
1030 CATCH_SET(oldcatch);
1035 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1036 qsortsv(ORIGMARK+1, max,
1037 (PL_op->op_private & OPpSORT_NUMERIC)
1038 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1039 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1040 : ( overloading ? amagic_ncmp : sv_ncmp))
1041 : ( IN_LOCALE_RUNTIME
1044 : sv_cmp_locale_static)
1045 : ( overloading ? amagic_cmp : sv_cmp_static)));
1046 if (PL_op->op_private & OPpSORT_REVERSE) {
1047 SV **p = ORIGMARK+1;
1048 SV **q = ORIGMARK+max;
1058 PL_stack_sp = ORIGMARK + max;
1066 if (GIMME == G_ARRAY)
1068 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1069 return cLOGOP->op_other;
1078 if (GIMME == G_ARRAY) {
1079 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1083 SV *targ = PAD_SV(PL_op->op_targ);
1086 if (PL_op->op_private & OPpFLIP_LINENUM) {
1088 flip = PL_last_in_gv
1089 && (gp_io = GvIO(PL_last_in_gv))
1090 && SvIV(sv) == (IV)IoLINES(gp_io);
1095 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1096 if (PL_op->op_flags & OPf_SPECIAL) {
1104 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1117 if (GIMME == G_ARRAY) {
1123 if (SvGMAGICAL(left))
1125 if (SvGMAGICAL(right))
1128 if (SvNIOKp(left) || !SvPOKp(left) ||
1129 SvNIOKp(right) || !SvPOKp(right) ||
1130 (looks_like_number(left) && *SvPVX(left) != '0' &&
1131 looks_like_number(right) && *SvPVX(right) != '0'))
1133 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1134 DIE(aTHX_ "Range iterator outside integer range");
1145 sv = sv_2mortal(newSViv(i++));
1150 SV *final = sv_mortalcopy(right);
1152 char *tmps = SvPV(final, len);
1154 sv = sv_mortalcopy(left);
1156 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1158 if (strEQ(SvPVX(sv),tmps))
1160 sv = sv_2mortal(newSVsv(sv));
1167 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1169 if ((PL_op->op_private & OPpFLIP_LINENUM)
1170 ? (GvIO(PL_last_in_gv)
1171 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1173 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1174 sv_catpv(targ, "E0");
1185 S_dopoptolabel(pTHX_ char *label)
1188 register PERL_CONTEXT *cx;
1190 for (i = cxstack_ix; i >= 0; i--) {
1192 switch (CxTYPE(cx)) {
1194 if (ckWARN(WARN_EXITING))
1195 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1196 PL_op_name[PL_op->op_type]);
1199 if (ckWARN(WARN_EXITING))
1200 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1201 PL_op_name[PL_op->op_type]);
1204 if (ckWARN(WARN_EXITING))
1205 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1206 PL_op_name[PL_op->op_type]);
1209 if (ckWARN(WARN_EXITING))
1210 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1211 PL_op_name[PL_op->op_type]);
1214 if (ckWARN(WARN_EXITING))
1215 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1216 PL_op_name[PL_op->op_type]);
1219 if (!cx->blk_loop.label ||
1220 strNE(label, cx->blk_loop.label) ) {
1221 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1222 (long)i, cx->blk_loop.label));
1225 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1233 Perl_dowantarray(pTHX)
1235 I32 gimme = block_gimme();
1236 return (gimme == G_VOID) ? G_SCALAR : gimme;
1240 Perl_block_gimme(pTHX)
1244 cxix = dopoptosub(cxstack_ix);
1248 switch (cxstack[cxix].blk_gimme) {
1256 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1263 Perl_is_lvalue_sub(pTHX)
1267 cxix = dopoptosub(cxstack_ix);
1268 assert(cxix >= 0); /* We should only be called from inside subs */
1270 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1271 return cxstack[cxix].blk_sub.lval;
1277 S_dopoptosub(pTHX_ I32 startingblock)
1279 return dopoptosub_at(cxstack, startingblock);
1283 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1286 register PERL_CONTEXT *cx;
1287 for (i = startingblock; i >= 0; i--) {
1289 switch (CxTYPE(cx)) {
1295 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1303 S_dopoptoeval(pTHX_ I32 startingblock)
1306 register PERL_CONTEXT *cx;
1307 for (i = startingblock; i >= 0; i--) {
1309 switch (CxTYPE(cx)) {
1313 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1321 S_dopoptoloop(pTHX_ I32 startingblock)
1324 register PERL_CONTEXT *cx;
1325 for (i = startingblock; i >= 0; i--) {
1327 switch (CxTYPE(cx)) {
1329 if (ckWARN(WARN_EXITING))
1330 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1331 PL_op_name[PL_op->op_type]);
1334 if (ckWARN(WARN_EXITING))
1335 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1336 PL_op_name[PL_op->op_type]);
1339 if (ckWARN(WARN_EXITING))
1340 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1341 PL_op_name[PL_op->op_type]);
1344 if (ckWARN(WARN_EXITING))
1345 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1346 PL_op_name[PL_op->op_type]);
1349 if (ckWARN(WARN_EXITING))
1350 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1351 PL_op_name[PL_op->op_type]);
1354 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1362 Perl_dounwind(pTHX_ I32 cxix)
1364 register PERL_CONTEXT *cx;
1367 while (cxstack_ix > cxix) {
1369 cx = &cxstack[cxstack_ix];
1370 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1371 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1372 /* Note: we don't need to restore the base context info till the end. */
1373 switch (CxTYPE(cx)) {
1376 continue; /* not break */
1398 Perl_qerror(pTHX_ SV *err)
1401 sv_catsv(ERRSV, err);
1403 sv_catsv(PL_errors, err);
1405 Perl_warn(aTHX_ "%"SVf, err);
1410 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1415 register PERL_CONTEXT *cx;
1420 if (PL_in_eval & EVAL_KEEPERR) {
1421 static char prefix[] = "\t(in cleanup) ";
1426 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1429 if (*e != *message || strNE(e,message))
1433 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1434 sv_catpvn(err, prefix, sizeof(prefix)-1);
1435 sv_catpvn(err, message, msglen);
1436 if (ckWARN(WARN_MISC)) {
1437 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1438 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1443 sv_setpvn(ERRSV, message, msglen);
1447 message = SvPVx(ERRSV, msglen);
1449 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1450 && PL_curstackinfo->si_prev)
1459 if (cxix < cxstack_ix)
1462 POPBLOCK(cx,PL_curpm);
1463 if (CxTYPE(cx) != CXt_EVAL) {
1464 PerlIO_write(Perl_error_log, "panic: die ", 11);
1465 PerlIO_write(Perl_error_log, message, msglen);
1470 if (gimme == G_SCALAR)
1471 *++newsp = &PL_sv_undef;
1472 PL_stack_sp = newsp;
1476 /* LEAVE could clobber PL_curcop (see save_re_context())
1477 * XXX it might be better to find a way to avoid messing with
1478 * PL_curcop in save_re_context() instead, but this is a more
1479 * minimal fix --GSAR */
1480 PL_curcop = cx->blk_oldcop;
1482 if (optype == OP_REQUIRE) {
1483 char* msg = SvPVx(ERRSV, n_a);
1484 DIE(aTHX_ "%sCompilation failed in require",
1485 *msg ? msg : "Unknown error\n");
1487 return pop_return();
1491 message = SvPVx(ERRSV, msglen);
1494 /* SFIO can really mess with your errno */
1497 PerlIO *serr = Perl_error_log;
1499 PerlIO_write(serr, message, msglen);
1500 (void)PerlIO_flush(serr);
1513 if (SvTRUE(left) != SvTRUE(right))
1525 RETURNOP(cLOGOP->op_other);
1534 RETURNOP(cLOGOP->op_other);
1540 register I32 cxix = dopoptosub(cxstack_ix);
1541 register PERL_CONTEXT *cx;
1542 register PERL_CONTEXT *ccstack = cxstack;
1543 PERL_SI *top_si = PL_curstackinfo;
1554 /* we may be in a higher stacklevel, so dig down deeper */
1555 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1556 top_si = top_si->si_prev;
1557 ccstack = top_si->si_cxstack;
1558 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1561 if (GIMME != G_ARRAY)
1565 if (PL_DBsub && cxix >= 0 &&
1566 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1570 cxix = dopoptosub_at(ccstack, cxix - 1);
1573 cx = &ccstack[cxix];
1574 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1575 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1576 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1577 field below is defined for any cx. */
1578 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1579 cx = &ccstack[dbcxix];
1582 stashname = CopSTASHPV(cx->blk_oldcop);
1583 if (GIMME != G_ARRAY) {
1585 PUSHs(&PL_sv_undef);
1588 sv_setpv(TARG, stashname);
1595 PUSHs(&PL_sv_undef);
1597 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1598 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1599 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1602 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1603 /* So is ccstack[dbcxix]. */
1605 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1606 PUSHs(sv_2mortal(sv));
1607 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1610 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1611 PUSHs(sv_2mortal(newSViv(0)));
1613 gimme = (I32)cx->blk_gimme;
1614 if (gimme == G_VOID)
1615 PUSHs(&PL_sv_undef);
1617 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1618 if (CxTYPE(cx) == CXt_EVAL) {
1620 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1621 PUSHs(cx->blk_eval.cur_text);
1625 else if (cx->blk_eval.old_namesv) {
1626 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1629 /* eval BLOCK (try blocks have old_namesv == 0) */
1631 PUSHs(&PL_sv_undef);
1632 PUSHs(&PL_sv_undef);
1636 PUSHs(&PL_sv_undef);
1637 PUSHs(&PL_sv_undef);
1639 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1640 && CopSTASH_eq(PL_curcop, PL_debstash))
1642 AV *ary = cx->blk_sub.argarray;
1643 int off = AvARRAY(ary) - AvALLOC(ary);
1647 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1650 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1653 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1654 av_extend(PL_dbargs, AvFILLp(ary) + off);
1655 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1656 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1658 /* XXX only hints propagated via op_private are currently
1659 * visible (others are not easily accessible, since they
1660 * use the global PL_hints) */
1661 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1662 HINT_PRIVATE_MASK)));
1665 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1667 if (old_warnings == pWARN_NONE ||
1668 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1669 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1670 else if (old_warnings == pWARN_ALL ||
1671 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1672 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1674 mask = newSVsv(old_warnings);
1675 PUSHs(sv_2mortal(mask));
1690 sv_reset(tmps, CopSTASH(PL_curcop));
1702 PL_curcop = (COP*)PL_op;
1703 TAINT_NOT; /* Each statement is presumed innocent */
1704 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1707 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1711 register PERL_CONTEXT *cx;
1712 I32 gimme = G_ARRAY;
1719 DIE(aTHX_ "No DB::DB routine defined");
1721 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1722 /* don't do recursive DB::DB call */
1734 push_return(PL_op->op_next);
1735 PUSHBLOCK(cx, CXt_SUB, SP);
1738 (void)SvREFCNT_inc(cv);
1739 SAVEVPTR(PL_curpad);
1740 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1741 RETURNOP(CvSTART(cv));
1755 register PERL_CONTEXT *cx;
1756 I32 gimme = GIMME_V;
1758 U32 cxtype = CXt_LOOP;
1767 if (PL_op->op_flags & OPf_SPECIAL) {
1768 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1769 SAVEGENERICSV(*svp);
1773 #endif /* USE_THREADS */
1774 if (PL_op->op_targ) {
1775 #ifndef USE_ITHREADS
1776 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1779 SAVEPADSV(PL_op->op_targ);
1780 iterdata = (void*)PL_op->op_targ;
1781 cxtype |= CXp_PADVAR;
1786 svp = &GvSV(gv); /* symbol table variable */
1787 SAVEGENERICSV(*svp);
1790 iterdata = (void*)gv;
1796 PUSHBLOCK(cx, cxtype, SP);
1798 PUSHLOOP(cx, iterdata, MARK);
1800 PUSHLOOP(cx, svp, MARK);
1802 if (PL_op->op_flags & OPf_STACKED) {
1803 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1804 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1806 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1807 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1808 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1809 looks_like_number((SV*)cx->blk_loop.iterary) &&
1810 *SvPVX(cx->blk_loop.iterary) != '0'))
1812 if (SvNV(sv) < IV_MIN ||
1813 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1814 DIE(aTHX_ "Range iterator outside integer range");
1815 cx->blk_loop.iterix = SvIV(sv);
1816 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1819 cx->blk_loop.iterlval = newSVsv(sv);
1823 cx->blk_loop.iterary = PL_curstack;
1824 AvFILLp(PL_curstack) = SP - PL_stack_base;
1825 cx->blk_loop.iterix = MARK - PL_stack_base;
1834 register PERL_CONTEXT *cx;
1835 I32 gimme = GIMME_V;
1841 PUSHBLOCK(cx, CXt_LOOP, SP);
1842 PUSHLOOP(cx, 0, SP);
1850 register PERL_CONTEXT *cx;
1858 newsp = PL_stack_base + cx->blk_loop.resetsp;
1861 if (gimme == G_VOID)
1863 else if (gimme == G_SCALAR) {
1865 *++newsp = sv_mortalcopy(*SP);
1867 *++newsp = &PL_sv_undef;
1871 *++newsp = sv_mortalcopy(*++mark);
1872 TAINT_NOT; /* Each item is independent */
1878 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1879 PL_curpm = newpm; /* ... and pop $1 et al */
1891 register PERL_CONTEXT *cx;
1892 bool popsub2 = FALSE;
1893 bool clear_errsv = FALSE;
1900 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1901 if (cxstack_ix == PL_sortcxix
1902 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1904 if (cxstack_ix > PL_sortcxix)
1905 dounwind(PL_sortcxix);
1906 AvARRAY(PL_curstack)[1] = *SP;
1907 PL_stack_sp = PL_stack_base + 1;
1912 cxix = dopoptosub(cxstack_ix);
1914 DIE(aTHX_ "Can't return outside a subroutine");
1915 if (cxix < cxstack_ix)
1919 switch (CxTYPE(cx)) {
1924 if (!(PL_in_eval & EVAL_KEEPERR))
1930 if (optype == OP_REQUIRE &&
1931 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1933 /* Unassume the success we assumed earlier. */
1934 SV *nsv = cx->blk_eval.old_namesv;
1935 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1936 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1943 DIE(aTHX_ "panic: return");
1947 if (gimme == G_SCALAR) {
1950 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1952 *++newsp = SvREFCNT_inc(*SP);
1957 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1959 *++newsp = sv_mortalcopy(sv);
1964 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1967 *++newsp = sv_mortalcopy(*SP);
1970 *++newsp = &PL_sv_undef;
1972 else if (gimme == G_ARRAY) {
1973 while (++MARK <= SP) {
1974 *++newsp = (popsub2 && SvTEMP(*MARK))
1975 ? *MARK : sv_mortalcopy(*MARK);
1976 TAINT_NOT; /* Each item is independent */
1979 PL_stack_sp = newsp;
1981 /* Stack values are safe: */
1983 POPSUB(cx,sv); /* release CV and @_ ... */
1987 PL_curpm = newpm; /* ... and pop $1 et al */
1993 return pop_return();
2000 register PERL_CONTEXT *cx;
2010 if (PL_op->op_flags & OPf_SPECIAL) {
2011 cxix = dopoptoloop(cxstack_ix);
2013 DIE(aTHX_ "Can't \"last\" outside a loop block");
2016 cxix = dopoptolabel(cPVOP->op_pv);
2018 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2020 if (cxix < cxstack_ix)
2025 switch (CxTYPE(cx)) {
2028 newsp = PL_stack_base + cx->blk_loop.resetsp;
2029 nextop = cx->blk_loop.last_op->op_next;
2033 nextop = pop_return();
2037 nextop = pop_return();
2041 nextop = pop_return();
2044 DIE(aTHX_ "panic: last");
2048 if (gimme == G_SCALAR) {
2050 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2051 ? *SP : sv_mortalcopy(*SP);
2053 *++newsp = &PL_sv_undef;
2055 else if (gimme == G_ARRAY) {
2056 while (++MARK <= SP) {
2057 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2058 ? *MARK : sv_mortalcopy(*MARK);
2059 TAINT_NOT; /* Each item is independent */
2065 /* Stack values are safe: */
2068 POPLOOP(cx); /* release loop vars ... */
2072 POPSUB(cx,sv); /* release CV and @_ ... */
2075 PL_curpm = newpm; /* ... and pop $1 et al */
2085 register PERL_CONTEXT *cx;
2088 if (PL_op->op_flags & OPf_SPECIAL) {
2089 cxix = dopoptoloop(cxstack_ix);
2091 DIE(aTHX_ "Can't \"next\" outside a loop block");
2094 cxix = dopoptolabel(cPVOP->op_pv);
2096 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2098 if (cxix < cxstack_ix)
2101 /* clear off anything above the scope we're re-entering, but
2102 * save the rest until after a possible continue block */
2103 inner = PL_scopestack_ix;
2105 if (PL_scopestack_ix < inner)
2106 leave_scope(PL_scopestack[PL_scopestack_ix]);
2107 return cx->blk_loop.next_op;
2113 register PERL_CONTEXT *cx;
2116 if (PL_op->op_flags & OPf_SPECIAL) {
2117 cxix = dopoptoloop(cxstack_ix);
2119 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2122 cxix = dopoptolabel(cPVOP->op_pv);
2124 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2126 if (cxix < cxstack_ix)
2130 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2131 LEAVE_SCOPE(oldsave);
2132 return cx->blk_loop.redo_op;
2136 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2140 static char too_deep[] = "Target of goto is too deeply nested";
2143 Perl_croak(aTHX_ too_deep);
2144 if (o->op_type == OP_LEAVE ||
2145 o->op_type == OP_SCOPE ||
2146 o->op_type == OP_LEAVELOOP ||
2147 o->op_type == OP_LEAVETRY)
2149 *ops++ = cUNOPo->op_first;
2151 Perl_croak(aTHX_ too_deep);
2154 if (o->op_flags & OPf_KIDS) {
2155 /* First try all the kids at this level, since that's likeliest. */
2156 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2157 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2158 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2162 if (kid == PL_lastgotoprobe)
2164 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2166 (ops[-1]->op_type != OP_NEXTSTATE &&
2167 ops[-1]->op_type != OP_DBSTATE)))
2169 if ((o = dofindlabel(kid, label, ops, oplimit)))
2188 register PERL_CONTEXT *cx;
2189 #define GOTO_DEPTH 64
2190 OP *enterops[GOTO_DEPTH];
2192 int do_dump = (PL_op->op_type == OP_DUMP);
2193 static char must_have_label[] = "goto must have label";
2196 if (PL_op->op_flags & OPf_STACKED) {
2200 /* This egregious kludge implements goto &subroutine */
2201 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2203 register PERL_CONTEXT *cx;
2204 CV* cv = (CV*)SvRV(sv);
2210 if (!CvROOT(cv) && !CvXSUB(cv)) {
2215 /* autoloaded stub? */
2216 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2218 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2219 GvNAMELEN(gv), FALSE);
2220 if (autogv && (cv = GvCV(autogv)))
2222 tmpstr = sv_newmortal();
2223 gv_efullname3(tmpstr, gv, Nullch);
2224 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2226 DIE(aTHX_ "Goto undefined subroutine");
2229 /* First do some returnish stuff. */
2230 cxix = dopoptosub(cxstack_ix);
2232 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2233 if (cxix < cxstack_ix)
2237 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2239 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2240 /* put @_ back onto stack */
2241 AV* av = cx->blk_sub.argarray;
2243 items = AvFILLp(av) + 1;
2245 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2246 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2247 PL_stack_sp += items;
2249 SvREFCNT_dec(GvAV(PL_defgv));
2250 GvAV(PL_defgv) = cx->blk_sub.savearray;
2251 #endif /* USE_THREADS */
2252 /* abandon @_ if it got reified */
2254 (void)sv_2mortal((SV*)av); /* delay until return */
2256 av_extend(av, items-1);
2257 AvFLAGS(av) = AVf_REIFY;
2258 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2261 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2264 av = (AV*)PL_curpad[0];
2266 av = GvAV(PL_defgv);
2268 items = AvFILLp(av) + 1;
2270 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2271 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2272 PL_stack_sp += items;
2274 if (CxTYPE(cx) == CXt_SUB &&
2275 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2276 SvREFCNT_dec(cx->blk_sub.cv);
2277 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2278 LEAVE_SCOPE(oldsave);
2280 /* Now do some callish stuff. */
2283 #ifdef PERL_XSUB_OLDSTYLE
2284 if (CvOLDSTYLE(cv)) {
2285 I32 (*fp3)(int,int,int);
2290 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2291 items = (*fp3)(CvXSUBANY(cv).any_i32,
2292 mark - PL_stack_base + 1,
2294 SP = PL_stack_base + items;
2297 #endif /* PERL_XSUB_OLDSTYLE */
2302 PL_stack_sp--; /* There is no cv arg. */
2303 /* Push a mark for the start of arglist */
2305 (void)(*CvXSUB(cv))(aTHXo_ cv);
2306 /* Pop the current context like a decent sub should */
2307 POPBLOCK(cx, PL_curpm);
2308 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2311 return pop_return();
2314 AV* padlist = CvPADLIST(cv);
2315 SV** svp = AvARRAY(padlist);
2316 if (CxTYPE(cx) == CXt_EVAL) {
2317 PL_in_eval = cx->blk_eval.old_in_eval;
2318 PL_eval_root = cx->blk_eval.old_eval_root;
2319 cx->cx_type = CXt_SUB;
2320 cx->blk_sub.hasargs = 0;
2322 cx->blk_sub.cv = cv;
2323 cx->blk_sub.olddepth = CvDEPTH(cv);
2325 if (CvDEPTH(cv) < 2)
2326 (void)SvREFCNT_inc(cv);
2327 else { /* save temporaries on recursion? */
2328 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2329 sub_crush_depth(cv);
2330 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2331 AV *newpad = newAV();
2332 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2333 I32 ix = AvFILLp((AV*)svp[1]);
2334 I32 names_fill = AvFILLp((AV*)svp[0]);
2335 svp = AvARRAY(svp[0]);
2336 for ( ;ix > 0; ix--) {
2337 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2338 char *name = SvPVX(svp[ix]);
2339 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2342 /* outer lexical or anon code */
2343 av_store(newpad, ix,
2344 SvREFCNT_inc(oldpad[ix]) );
2346 else { /* our own lexical */
2348 av_store(newpad, ix, sv = (SV*)newAV());
2349 else if (*name == '%')
2350 av_store(newpad, ix, sv = (SV*)newHV());
2352 av_store(newpad, ix, sv = NEWSV(0,0));
2356 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2357 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2360 av_store(newpad, ix, sv = NEWSV(0,0));
2364 if (cx->blk_sub.hasargs) {
2367 av_store(newpad, 0, (SV*)av);
2368 AvFLAGS(av) = AVf_REIFY;
2370 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2371 AvFILLp(padlist) = CvDEPTH(cv);
2372 svp = AvARRAY(padlist);
2376 if (!cx->blk_sub.hasargs) {
2377 AV* av = (AV*)PL_curpad[0];
2379 items = AvFILLp(av) + 1;
2381 /* Mark is at the end of the stack. */
2383 Copy(AvARRAY(av), SP + 1, items, SV*);
2388 #endif /* USE_THREADS */
2389 SAVEVPTR(PL_curpad);
2390 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2392 if (cx->blk_sub.hasargs)
2393 #endif /* USE_THREADS */
2395 AV* av = (AV*)PL_curpad[0];
2399 cx->blk_sub.savearray = GvAV(PL_defgv);
2400 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2401 #endif /* USE_THREADS */
2402 cx->blk_sub.oldcurpad = PL_curpad;
2403 cx->blk_sub.argarray = av;
2406 if (items >= AvMAX(av) + 1) {
2408 if (AvARRAY(av) != ary) {
2409 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2410 SvPVX(av) = (char*)ary;
2412 if (items >= AvMAX(av) + 1) {
2413 AvMAX(av) = items - 1;
2414 Renew(ary,items+1,SV*);
2416 SvPVX(av) = (char*)ary;
2419 Copy(mark,AvARRAY(av),items,SV*);
2420 AvFILLp(av) = items - 1;
2421 assert(!AvREAL(av));
2428 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2430 * We do not care about using sv to call CV;
2431 * it's for informational purposes only.
2433 SV *sv = GvSV(PL_DBsub);
2436 if (PERLDB_SUB_NN) {
2437 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2440 gv_efullname3(sv, CvGV(cv), Nullch);
2443 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2444 PUSHMARK( PL_stack_sp );
2445 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2449 RETURNOP(CvSTART(cv));
2453 label = SvPV(sv,n_a);
2454 if (!(do_dump || *label))
2455 DIE(aTHX_ must_have_label);
2458 else if (PL_op->op_flags & OPf_SPECIAL) {
2460 DIE(aTHX_ must_have_label);
2463 label = cPVOP->op_pv;
2465 if (label && *label) {
2467 bool leaving_eval = FALSE;
2468 PERL_CONTEXT *last_eval_cx = 0;
2472 PL_lastgotoprobe = 0;
2474 for (ix = cxstack_ix; ix >= 0; ix--) {
2476 switch (CxTYPE(cx)) {
2478 leaving_eval = TRUE;
2479 if (CxREALEVAL(cx)) {
2480 gotoprobe = (last_eval_cx ?
2481 last_eval_cx->blk_eval.old_eval_root :
2486 /* else fall through */
2488 gotoprobe = cx->blk_oldcop->op_sibling;
2494 gotoprobe = cx->blk_oldcop->op_sibling;
2496 gotoprobe = PL_main_root;
2499 if (CvDEPTH(cx->blk_sub.cv)) {
2500 gotoprobe = CvROOT(cx->blk_sub.cv);
2506 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2509 DIE(aTHX_ "panic: goto");
2510 gotoprobe = PL_main_root;
2514 retop = dofindlabel(gotoprobe, label,
2515 enterops, enterops + GOTO_DEPTH);
2519 PL_lastgotoprobe = gotoprobe;
2522 DIE(aTHX_ "Can't find label %s", label);
2524 /* if we're leaving an eval, check before we pop any frames
2525 that we're not going to punt, otherwise the error
2528 if (leaving_eval && *enterops && enterops[1]) {
2530 for (i = 1; enterops[i]; i++)
2531 if (enterops[i]->op_type == OP_ENTERITER)
2532 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2535 /* pop unwanted frames */
2537 if (ix < cxstack_ix) {
2544 oldsave = PL_scopestack[PL_scopestack_ix];
2545 LEAVE_SCOPE(oldsave);
2548 /* push wanted frames */
2550 if (*enterops && enterops[1]) {
2552 for (ix = 1; enterops[ix]; ix++) {
2553 PL_op = enterops[ix];
2554 /* Eventually we may want to stack the needed arguments
2555 * for each op. For now, we punt on the hard ones. */
2556 if (PL_op->op_type == OP_ENTERITER)
2557 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2558 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2566 if (!retop) retop = PL_main_start;
2568 PL_restartop = retop;
2569 PL_do_undump = TRUE;
2573 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2574 PL_do_undump = FALSE;
2590 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2594 PL_exit_flags |= PERL_EXIT_EXPECTED;
2596 PUSHs(&PL_sv_undef);
2604 NV value = SvNVx(GvSV(cCOP->cop_gv));
2605 register I32 match = I_32(value);
2608 if (((NV)match) > value)
2609 --match; /* was fractional--truncate other way */
2611 match -= cCOP->uop.scop.scop_offset;
2614 else if (match > cCOP->uop.scop.scop_max)
2615 match = cCOP->uop.scop.scop_max;
2616 PL_op = cCOP->uop.scop.scop_next[match];
2626 PL_op = PL_op->op_next; /* can't assume anything */
2629 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2630 match -= cCOP->uop.scop.scop_offset;
2633 else if (match > cCOP->uop.scop.scop_max)
2634 match = cCOP->uop.scop.scop_max;
2635 PL_op = cCOP->uop.scop.scop_next[match];
2644 S_save_lines(pTHX_ AV *array, SV *sv)
2646 register char *s = SvPVX(sv);
2647 register char *send = SvPVX(sv) + SvCUR(sv);
2649 register I32 line = 1;
2651 while (s && s < send) {
2652 SV *tmpstr = NEWSV(85,0);
2654 sv_upgrade(tmpstr, SVt_PVMG);
2655 t = strchr(s, '\n');
2661 sv_setpvn(tmpstr, s, t - s);
2662 av_store(array, line++, tmpstr);
2667 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2669 S_docatch_body(pTHX_ va_list args)
2671 return docatch_body();
2676 S_docatch_body(pTHX)
2683 S_docatch(pTHX_ OP *o)
2687 volatile PERL_SI *cursi = PL_curstackinfo;
2691 assert(CATCH_GET == TRUE);
2694 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2696 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2702 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2708 if (PL_restartop && cursi == PL_curstackinfo) {
2709 PL_op = PL_restartop;
2726 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2727 /* sv Text to convert to OP tree. */
2728 /* startop op_free() this to undo. */
2729 /* code Short string id of the caller. */
2731 dSP; /* Make POPBLOCK work. */
2734 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2738 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2739 char *tmpbuf = tbuf;
2745 /* switch to eval mode */
2747 if (PL_curcop == &PL_compiling) {
2748 SAVECOPSTASH_FREE(&PL_compiling);
2749 CopSTASH_set(&PL_compiling, PL_curstash);
2751 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2752 SV *sv = sv_newmortal();
2753 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2754 code, (unsigned long)++PL_evalseq,
2755 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2759 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2760 SAVECOPFILE_FREE(&PL_compiling);
2761 CopFILE_set(&PL_compiling, tmpbuf+2);
2762 SAVECOPLINE(&PL_compiling);
2763 CopLINE_set(&PL_compiling, 1);
2764 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2765 deleting the eval's FILEGV from the stash before gv_check() runs
2766 (i.e. before run-time proper). To work around the coredump that
2767 ensues, we always turn GvMULTI_on for any globals that were
2768 introduced within evals. See force_ident(). GSAR 96-10-12 */
2769 safestr = savepv(tmpbuf);
2770 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2772 #ifdef OP_IN_REGISTER
2777 PL_hints &= HINT_UTF8;
2780 PL_op->op_type = OP_ENTEREVAL;
2781 PL_op->op_flags = 0; /* Avoid uninit warning. */
2782 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2783 PUSHEVAL(cx, 0, Nullgv);
2784 rop = doeval(G_SCALAR, startop);
2785 POPBLOCK(cx,PL_curpm);
2788 (*startop)->op_type = OP_NULL;
2789 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2791 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2793 if (PL_curcop == &PL_compiling)
2794 PL_compiling.op_private = PL_hints;
2795 #ifdef OP_IN_REGISTER
2801 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2803 S_doeval(pTHX_ int gimme, OP** startop)
2811 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2812 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2817 /* set up a scratch pad */
2820 SAVEVPTR(PL_curpad);
2821 SAVESPTR(PL_comppad);
2822 SAVESPTR(PL_comppad_name);
2823 SAVEI32(PL_comppad_name_fill);
2824 SAVEI32(PL_min_intro_pending);
2825 SAVEI32(PL_max_intro_pending);
2828 for (i = cxstack_ix - 1; i >= 0; i--) {
2829 PERL_CONTEXT *cx = &cxstack[i];
2830 if (CxTYPE(cx) == CXt_EVAL)
2832 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2833 caller = cx->blk_sub.cv;
2838 SAVESPTR(PL_compcv);
2839 PL_compcv = (CV*)NEWSV(1104,0);
2840 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2841 CvEVAL_on(PL_compcv);
2842 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2843 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2846 CvOWNER(PL_compcv) = 0;
2847 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2848 MUTEX_INIT(CvMUTEXP(PL_compcv));
2849 #endif /* USE_THREADS */
2851 PL_comppad = newAV();
2852 av_push(PL_comppad, Nullsv);
2853 PL_curpad = AvARRAY(PL_comppad);
2854 PL_comppad_name = newAV();
2855 PL_comppad_name_fill = 0;
2856 PL_min_intro_pending = 0;
2859 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2860 PL_curpad[0] = (SV*)newAV();
2861 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2862 #endif /* USE_THREADS */
2864 comppadlist = newAV();
2865 AvREAL_off(comppadlist);
2866 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2867 av_store(comppadlist, 1, (SV*)PL_comppad);
2868 CvPADLIST(PL_compcv) = comppadlist;
2871 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2873 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2876 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2878 /* make sure we compile in the right package */
2880 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2881 SAVESPTR(PL_curstash);
2882 PL_curstash = CopSTASH(PL_curcop);
2884 SAVESPTR(PL_beginav);
2885 PL_beginav = newAV();
2886 SAVEFREESV(PL_beginav);
2887 SAVEI32(PL_error_count);
2889 /* try to compile it */
2891 PL_eval_root = Nullop;
2893 PL_curcop = &PL_compiling;
2894 PL_curcop->cop_arybase = 0;
2895 SvREFCNT_dec(PL_rs);
2896 PL_rs = newSVpvn("\n", 1);
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 SvREFCNT_dec(PL_rs);
2935 PL_rs = SvREFCNT_inc(PL_nrs);
2937 MUTEX_LOCK(&PL_eval_mutex);
2939 COND_SIGNAL(&PL_eval_cond);
2940 MUTEX_UNLOCK(&PL_eval_mutex);
2941 #endif /* USE_THREADS */
2944 SvREFCNT_dec(PL_rs);
2945 PL_rs = SvREFCNT_inc(PL_nrs);
2946 CopLINE_set(&PL_compiling, 0);
2948 *startop = PL_eval_root;
2949 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2950 CvOUTSIDE(PL_compcv) = Nullcv;
2952 SAVEFREEOP(PL_eval_root);
2954 scalarvoid(PL_eval_root);
2955 else if (gimme & G_ARRAY)
2958 scalar(PL_eval_root);
2960 DEBUG_x(dump_eval());
2962 /* Register with debugger: */
2963 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2964 CV *cv = get_cv("DB::postponed", FALSE);
2968 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2970 call_sv((SV*)cv, G_DISCARD);
2974 /* compiled okay, so do it */
2976 CvDEPTH(PL_compcv) = 1;
2977 SP = PL_stack_base + POPMARK; /* pop original mark */
2978 PL_op = saveop; /* The caller may need it. */
2979 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2981 MUTEX_LOCK(&PL_eval_mutex);
2983 COND_SIGNAL(&PL_eval_cond);
2984 MUTEX_UNLOCK(&PL_eval_mutex);
2985 #endif /* USE_THREADS */
2987 RETURNOP(PL_eval_start);
2991 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2993 STRLEN namelen = strlen(name);
2996 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2997 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2998 char *pmc = SvPV_nolen(pmcsv);
3001 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3002 fp = PerlIO_open(name, mode);
3005 if (PerlLIO_stat(name, &pmstat) < 0 ||
3006 pmstat.st_mtime < pmcstat.st_mtime)
3008 fp = PerlIO_open(pmc, mode);
3011 fp = PerlIO_open(name, mode);
3014 SvREFCNT_dec(pmcsv);
3017 fp = PerlIO_open(name, mode);
3025 register PERL_CONTEXT *cx;
3029 char *tryname = Nullch;
3030 SV *namesv = Nullsv;
3032 I32 gimme = GIMME_V;
3033 PerlIO *tryrsfp = 0;
3035 int filter_has_file = 0;
3036 GV *filter_child_proc = 0;
3037 SV *filter_state = 0;
3042 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3043 UV rev = 0, ver = 0, sver = 0;
3045 U8 *s = (U8*)SvPVX(sv);
3046 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3048 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3051 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3054 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3057 if (PERL_REVISION < rev
3058 || (PERL_REVISION == rev
3059 && (PERL_VERSION < ver
3060 || (PERL_VERSION == ver
3061 && PERL_SUBVERSION < sver))))
3063 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3064 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3065 PERL_VERSION, PERL_SUBVERSION);
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".%"UVuf".0?)",
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 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3153 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3154 PTR2UV(SvANY(loader)), name);
3155 tryname = SvPVX(namesv);
3166 if (sv_isobject(loader))
3167 count = call_method("INC", G_ARRAY);
3169 count = call_sv(loader, G_ARRAY);
3179 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3183 if (SvTYPE(arg) == SVt_PVGV) {
3184 IO *io = GvIO((GV *)arg);
3189 tryrsfp = IoIFP(io);
3190 if (IoTYPE(io) == IoTYPE_PIPE) {
3191 /* reading from a child process doesn't
3192 nest -- when returning from reading
3193 the inner module, the outer one is
3194 unreadable (closed?) I've tried to
3195 save the gv to manage the lifespan of
3196 the pipe, but this didn't help. XXX */
3197 filter_child_proc = (GV *)arg;
3198 (void)SvREFCNT_inc(filter_child_proc);
3201 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3202 PerlIO_close(IoOFP(io));
3214 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3216 (void)SvREFCNT_inc(filter_sub);
3219 filter_state = SP[i];
3220 (void)SvREFCNT_inc(filter_state);
3224 tryrsfp = PerlIO_open("/dev/null",
3238 filter_has_file = 0;
3239 if (filter_child_proc) {
3240 SvREFCNT_dec(filter_child_proc);
3241 filter_child_proc = 0;
3244 SvREFCNT_dec(filter_state);
3248 SvREFCNT_dec(filter_sub);
3253 char *dir = SvPVx(dirsv, n_a);
3254 #ifdef MACOS_TRADITIONAL
3256 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3260 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3262 sv_setpv(namesv, unixdir);
3263 sv_catpv(namesv, unixname);
3265 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3268 TAINT_PROPER("require");
3269 tryname = SvPVX(namesv);
3270 #ifdef MACOS_TRADITIONAL
3272 /* Convert slashes in the name part, but not the directory part, to colons */
3274 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3278 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3280 if (tryname[0] == '.' && tryname[1] == '/')
3288 SAVECOPFILE_FREE(&PL_compiling);
3289 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3290 SvREFCNT_dec(namesv);
3292 if (PL_op->op_type == OP_REQUIRE) {
3293 char *msgstr = name;
3294 if (namesv) { /* did we lookup @INC? */
3295 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3296 SV *dirmsgsv = NEWSV(0, 0);
3297 AV *ar = GvAVn(PL_incgv);
3299 sv_catpvn(msg, " in @INC", 8);
3300 if (instr(SvPVX(msg), ".h "))
3301 sv_catpv(msg, " (change .h to .ph maybe?)");
3302 if (instr(SvPVX(msg), ".ph "))
3303 sv_catpv(msg, " (did you run h2ph?)");
3304 sv_catpv(msg, " (@INC contains:");
3305 for (i = 0; i <= AvFILL(ar); i++) {
3306 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3307 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3308 sv_catsv(msg, dirmsgsv);
3310 sv_catpvn(msg, ")", 1);
3311 SvREFCNT_dec(dirmsgsv);
3312 msgstr = SvPV_nolen(msg);
3314 DIE(aTHX_ "Can't locate %s", msgstr);
3320 SETERRNO(0, SS$_NORMAL);
3322 /* Assume success here to prevent recursive requirement. */
3323 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3324 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3328 lex_start(sv_2mortal(newSVpvn("",0)));
3329 SAVEGENERICSV(PL_rsfp_filters);
3330 PL_rsfp_filters = Nullav;
3335 SAVESPTR(PL_compiling.cop_warnings);
3336 if (PL_dowarn & G_WARN_ALL_ON)
3337 PL_compiling.cop_warnings = pWARN_ALL ;
3338 else if (PL_dowarn & G_WARN_ALL_OFF)
3339 PL_compiling.cop_warnings = pWARN_NONE ;
3341 PL_compiling.cop_warnings = pWARN_STD ;
3342 SAVESPTR(PL_compiling.cop_io);
3343 PL_compiling.cop_io = Nullsv;
3345 if (filter_sub || filter_child_proc) {
3346 SV *datasv = filter_add(run_user_filter, Nullsv);
3347 IoLINES(datasv) = filter_has_file;
3348 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3349 IoTOP_GV(datasv) = (GV *)filter_state;
3350 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3353 /* switch to eval mode */
3354 push_return(PL_op->op_next);
3355 PUSHBLOCK(cx, CXt_EVAL, SP);
3356 PUSHEVAL(cx, name, Nullgv);
3358 SAVECOPLINE(&PL_compiling);
3359 CopLINE_set(&PL_compiling, 0);
3363 MUTEX_LOCK(&PL_eval_mutex);
3364 if (PL_eval_owner && PL_eval_owner != thr)
3365 while (PL_eval_owner)
3366 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3367 PL_eval_owner = thr;
3368 MUTEX_UNLOCK(&PL_eval_mutex);
3369 #endif /* USE_THREADS */
3370 return DOCATCH(doeval(gimme, NULL));
3375 return pp_require();
3381 register PERL_CONTEXT *cx;
3383 I32 gimme = GIMME_V, was = PL_sub_generation;
3384 char tbuf[TYPE_DIGITS(long) + 12];
3385 char *tmpbuf = tbuf;
3390 if (!SvPV(sv,len) || !len)
3392 TAINT_PROPER("eval");
3398 /* switch to eval mode */
3400 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3401 SV *sv = sv_newmortal();
3402 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3403 (unsigned long)++PL_evalseq,
3404 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3408 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3409 SAVECOPFILE_FREE(&PL_compiling);
3410 CopFILE_set(&PL_compiling, tmpbuf+2);
3411 SAVECOPLINE(&PL_compiling);
3412 CopLINE_set(&PL_compiling, 1);
3413 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3414 deleting the eval's FILEGV from the stash before gv_check() runs
3415 (i.e. before run-time proper). To work around the coredump that
3416 ensues, we always turn GvMULTI_on for any globals that were
3417 introduced within evals. See force_ident(). GSAR 96-10-12 */
3418 safestr = savepv(tmpbuf);
3419 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3421 PL_hints = PL_op->op_targ;
3422 SAVESPTR(PL_compiling.cop_warnings);
3423 if (specialWARN(PL_curcop->cop_warnings))
3424 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3426 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3427 SAVEFREESV(PL_compiling.cop_warnings);
3429 SAVESPTR(PL_compiling.cop_io);
3430 if (specialCopIO(PL_curcop->cop_io))
3431 PL_compiling.cop_io = PL_curcop->cop_io;
3433 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3434 SAVEFREESV(PL_compiling.cop_io);
3437 push_return(PL_op->op_next);
3438 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3439 PUSHEVAL(cx, 0, Nullgv);
3441 /* prepare to compile string */
3443 if (PERLDB_LINE && PL_curstash != PL_debstash)
3444 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3447 MUTEX_LOCK(&PL_eval_mutex);
3448 if (PL_eval_owner && PL_eval_owner != thr)
3449 while (PL_eval_owner)
3450 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3451 PL_eval_owner = thr;
3452 MUTEX_UNLOCK(&PL_eval_mutex);
3453 #endif /* USE_THREADS */
3454 ret = doeval(gimme, NULL);
3455 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3456 && ret != PL_op->op_next) { /* Successive compilation. */
3457 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3459 return DOCATCH(ret);
3469 register PERL_CONTEXT *cx;
3471 U8 save_flags = PL_op -> op_flags;
3476 retop = pop_return();
3479 if (gimme == G_VOID)
3481 else if (gimme == G_SCALAR) {
3484 if (SvFLAGS(TOPs) & SVs_TEMP)
3487 *MARK = sv_mortalcopy(TOPs);
3491 *MARK = &PL_sv_undef;
3496 /* in case LEAVE wipes old return values */
3497 for (mark = newsp + 1; mark <= SP; mark++) {
3498 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3499 *mark = sv_mortalcopy(*mark);
3500 TAINT_NOT; /* Each item is independent */
3504 PL_curpm = newpm; /* Don't pop $1 et al till now */
3507 assert(CvDEPTH(PL_compcv) == 1);
3509 CvDEPTH(PL_compcv) = 0;
3512 if (optype == OP_REQUIRE &&
3513 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3515 /* Unassume the success we assumed earlier. */
3516 SV *nsv = cx->blk_eval.old_namesv;
3517 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3518 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3519 /* die_where() did LEAVE, or we won't be here */
3523 if (!(save_flags & OPf_SPECIAL))
3533 register PERL_CONTEXT *cx;
3534 I32 gimme = GIMME_V;
3539 push_return(cLOGOP->op_other->op_next);
3540 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3543 PL_in_eval = EVAL_INEVAL;
3546 return DOCATCH(PL_op->op_next);
3556 register PERL_CONTEXT *cx;
3564 if (gimme == G_VOID)
3566 else if (gimme == G_SCALAR) {
3569 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3572 *MARK = sv_mortalcopy(TOPs);
3576 *MARK = &PL_sv_undef;
3581 /* in case LEAVE wipes old return values */
3582 for (mark = newsp + 1; mark <= SP; mark++) {
3583 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3584 *mark = sv_mortalcopy(*mark);
3585 TAINT_NOT; /* Each item is independent */
3589 PL_curpm = newpm; /* Don't pop $1 et al till now */
3597 S_doparseform(pTHX_ SV *sv)
3600 register char *s = SvPV_force(sv, len);
3601 register char *send = s + len;
3602 register char *base = Nullch;
3603 register I32 skipspaces = 0;
3604 bool noblank = FALSE;
3605 bool repeat = FALSE;
3606 bool postspace = FALSE;
3614 Perl_croak(aTHX_ "Null picture in formline");
3616 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3621 *fpc++ = FF_LINEMARK;
3622 noblank = repeat = FALSE;
3640 case ' ': case '\t':
3651 *fpc++ = FF_LITERAL;
3659 *fpc++ = skipspaces;
3663 *fpc++ = FF_NEWLINE;
3667 arg = fpc - linepc + 1;
3674 *fpc++ = FF_LINEMARK;
3675 noblank = repeat = FALSE;
3684 ischop = s[-1] == '^';
3690 arg = (s - base) - 1;
3692 *fpc++ = FF_LITERAL;
3701 *fpc++ = FF_LINEGLOB;
3703 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3704 arg = ischop ? 512 : 0;
3714 arg |= 256 + (s - f);
3716 *fpc++ = s - base; /* fieldsize for FETCH */
3717 *fpc++ = FF_DECIMAL;
3720 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3721 arg = ischop ? 512 : 0;
3723 s++; /* skip the '0' first */
3732 arg |= 256 + (s - f);
3734 *fpc++ = s - base; /* fieldsize for FETCH */
3735 *fpc++ = FF_0DECIMAL;
3740 bool ismore = FALSE;
3743 while (*++s == '>') ;
3744 prespace = FF_SPACE;
3746 else if (*s == '|') {
3747 while (*++s == '|') ;
3748 prespace = FF_HALFSPACE;
3753 while (*++s == '<') ;
3756 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3760 *fpc++ = s - base; /* fieldsize for FETCH */
3762 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3780 { /* need to jump to the next word */
3782 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3783 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3784 s = SvPVX(sv) + SvCUR(sv) + z;
3786 Copy(fops, s, arg, U16);
3788 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3793 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3795 * The original code was written in conjunction with BSD Computer Software
3796 * Research Group at University of California, Berkeley.
3798 * See also: "Optimistic Merge Sort" (SODA '92)
3800 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3802 * The code can be distributed under the same terms as Perl itself.
3807 #include <sys/types.h>
3812 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3813 #define Safefree(VAR) free(VAR)
3814 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3815 #endif /* TESTHARNESS */
3817 typedef char * aptr; /* pointer for arithmetic on sizes */
3818 typedef SV * gptr; /* pointers in our lists */
3820 /* Binary merge internal sort, with a few special mods
3821 ** for the special perl environment it now finds itself in.
3823 ** Things that were once options have been hotwired
3824 ** to values suitable for this use. In particular, we'll always
3825 ** initialize looking for natural runs, we'll always produce stable
3826 ** output, and we'll always do Peter McIlroy's binary merge.
3829 /* Pointer types for arithmetic and storage and convenience casts */
3831 #define APTR(P) ((aptr)(P))
3832 #define GPTP(P) ((gptr *)(P))
3833 #define GPPP(P) ((gptr **)(P))
3836 /* byte offset from pointer P to (larger) pointer Q */
3837 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3839 #define PSIZE sizeof(gptr)
3841 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3844 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3845 #define PNBYTE(N) ((N) << (PSHIFT))
3846 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3848 /* Leave optimization to compiler */
3849 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3850 #define PNBYTE(N) ((N) * (PSIZE))
3851 #define PINDEX(P, N) (GPTP(P) + (N))
3854 /* Pointer into other corresponding to pointer into this */
3855 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3857 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3860 /* Runs are identified by a pointer in the auxilliary list.
3861 ** The pointer is at the start of the list,
3862 ** and it points to the start of the next list.
3863 ** NEXT is used as an lvalue, too.
3866 #define NEXT(P) (*GPPP(P))
3869 /* PTHRESH is the minimum number of pairs with the same sense to justify
3870 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3871 ** not just elements, so PTHRESH == 8 means a run of 16.
3876 /* RTHRESH is the number of elements in a run that must compare low
3877 ** to the low element from the opposing run before we justify
3878 ** doing a binary rampup instead of single stepping.
3879 ** In random input, N in a row low should only happen with
3880 ** probability 2^(1-N), so we can risk that we are dealing
3881 ** with orderly input without paying much when we aren't.
3888 ** Overview of algorithm and variables.
3889 ** The array of elements at list1 will be organized into runs of length 2,
3890 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3891 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3893 ** Unless otherwise specified, pair pointers address the first of two elements.
3895 ** b and b+1 are a pair that compare with sense ``sense''.
3896 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3898 ** p2 parallels b in the list2 array, where runs are defined by
3901 ** t represents the ``top'' of the adjacent pairs that might extend
3902 ** the run beginning at b. Usually, t addresses a pair
3903 ** that compares with opposite sense from (b,b+1).
3904 ** However, it may also address a singleton element at the end of list1,
3905 ** or it may be equal to ``last'', the first element beyond list1.
3907 ** r addresses the Nth pair following b. If this would be beyond t,
3908 ** we back it off to t. Only when r is less than t do we consider the
3909 ** run long enough to consider checking.
3911 ** q addresses a pair such that the pairs at b through q already form a run.
3912 ** Often, q will equal b, indicating we only are sure of the pair itself.
3913 ** However, a search on the previous cycle may have revealed a longer run,
3914 ** so q may be greater than b.
3916 ** p is used to work back from a candidate r, trying to reach q,
3917 ** which would mean b through r would be a run. If we discover such a run,
3918 ** we start q at r and try to push it further towards t.
3919 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3920 ** In any event, after the check (if any), we have two main cases.
3922 ** 1) Short run. b <= q < p <= r <= t.
3923 ** b through q is a run (perhaps trivial)
3924 ** q through p are uninteresting pairs
3925 ** p through r is a run
3927 ** 2) Long run. b < r <= q < t.
3928 ** b through q is a run (of length >= 2 * PTHRESH)
3930 ** Note that degenerate cases are not only possible, but likely.
3931 ** For example, if the pair following b compares with opposite sense,
3932 ** then b == q < p == r == t.
3937 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3940 register gptr *b, *p, *q, *t, *p2;
3941 register gptr c, *last, *r;
3945 last = PINDEX(b, nmemb);
3946 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3947 for (p2 = list2; b < last; ) {
3948 /* We just started, or just reversed sense.
3949 ** Set t at end of pairs with the prevailing sense.
3951 for (p = b+2, t = p; ++p < last; t = ++p) {
3952 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3955 /* Having laid out the playing field, look for long runs */
3957 p = r = b + (2 * PTHRESH);
3958 if (r >= t) p = r = t; /* too short to care about */
3960 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3963 /* b through r is a (long) run.
3964 ** Extend it as far as possible.
3967 while (((p += 2) < t) &&
3968 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3969 r = p = q + 2; /* no simple pairs, no after-run */
3972 if (q > b) { /* run of greater than 2 at b */
3975 /* pick up singleton, if possible */
3977 ((t + 1) == last) &&
3978 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3979 savep = r = p = q = last;
3980 p2 = NEXT(p2) = p2 + (p - b);
3981 if (sense) while (b < --p) {
3988 while (q < p) { /* simple pairs */
3989 p2 = NEXT(p2) = p2 + 2;
3996 if (((b = p) == t) && ((t+1) == last)) {
4008 /* Overview of bmerge variables:
4010 ** list1 and list2 address the main and auxiliary arrays.
4011 ** They swap identities after each merge pass.
4012 ** Base points to the original list1, so we can tell if
4013 ** the pointers ended up where they belonged (or must be copied).
4015 ** When we are merging two lists, f1 and f2 are the next elements
4016 ** on the respective lists. l1 and l2 mark the end of the lists.
4017 ** tp2 is the current location in the merged list.
4019 ** p1 records where f1 started.
4020 ** After the merge, a new descriptor is built there.
4022 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4023 ** It is used to identify and delimit the runs.
4025 ** In the heat of determining where q, the greater of the f1/f2 elements,
4026 ** belongs in the other list, b, t and p, represent bottom, top and probe
4027 ** locations, respectively, in the other list.
4028 ** They make convenient temporary pointers in other places.
4032 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4036 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4037 gptr *aux, *list2, *p2, *last;
4041 if (nmemb <= 1) return; /* sorted trivially */
4042 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4044 dynprep(aTHX_ list1, list2, nmemb, cmp);
4045 last = PINDEX(list2, nmemb);
4046 while (NEXT(list2) != last) {
4047 /* More than one run remains. Do some merging to reduce runs. */
4049 for (tp2 = p2 = list2; p2 != last;) {
4050 /* The new first run begins where the old second list ended.
4051 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4055 f2 = l1 = POTHER(t, list2, list1);
4056 if (t != last) t = NEXT(t);
4057 l2 = POTHER(t, list2, list1);
4059 while (f1 < l1 && f2 < l2) {
4060 /* If head 1 is larger than head 2, find ALL the elements
4061 ** in list 2 strictly less than head1, write them all,
4062 ** then head 1. Then compare the new heads, and repeat,
4063 ** until one or both lists are exhausted.
4065 ** In all comparisons (after establishing
4066 ** which head to merge) the item to merge
4067 ** (at pointer q) is the first operand of
4068 ** the comparison. When we want to know
4069 ** if ``q is strictly less than the other'',
4071 ** cmp(q, other) < 0
4072 ** because stability demands that we treat equality
4073 ** as high when q comes from l2, and as low when
4074 ** q was from l1. So we ask the question by doing
4075 ** cmp(q, other) <= sense
4076 ** and make sense == 0 when equality should look low,
4077 ** and -1 when equality should look high.
4081 if (cmp(aTHX_ *f1, *f2) <= 0) {
4082 q = f2; b = f1; t = l1;
4085 q = f1; b = f2; t = l2;
4092 ** Leave t at something strictly
4093 ** greater than q (or at the end of the list),
4094 ** and b at something strictly less than q.
4096 for (i = 1, run = 0 ;;) {
4097 if ((p = PINDEX(b, i)) >= t) {
4099 if (((p = PINDEX(t, -1)) > b) &&
4100 (cmp(aTHX_ *q, *p) <= sense))
4104 } else if (cmp(aTHX_ *q, *p) <= sense) {
4108 if (++run >= RTHRESH) i += i;
4112 /* q is known to follow b and must be inserted before t.
4113 ** Increment b, so the range of possibilities is [b,t).
4114 ** Round binary split down, to favor early appearance.
4115 ** Adjust b and t until q belongs just before t.
4120 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4121 if (cmp(aTHX_ *q, *p) <= sense) {
4127 /* Copy all the strictly low elements */
4130 FROMTOUPTO(f2, tp2, t);
4133 FROMTOUPTO(f1, tp2, t);
4139 /* Run out remaining list */
4141 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4142 } else FROMTOUPTO(f1, tp2, l1);
4143 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4148 last = PINDEX(list2, nmemb);
4150 if (base == list2) {
4151 last = PINDEX(list1, nmemb);
4152 FROMTOUPTO(list1, list2, last);
4167 sortcv(pTHXo_ SV *a, SV *b)
4169 I32 oldsaveix = PL_savestack_ix;
4170 I32 oldscopeix = PL_scopestack_ix;
4172 GvSV(PL_firstgv) = a;
4173 GvSV(PL_secondgv) = b;
4174 PL_stack_sp = PL_stack_base;
4177 if (PL_stack_sp != PL_stack_base + 1)
4178 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4179 if (!SvNIOKp(*PL_stack_sp))
4180 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4181 result = SvIV(*PL_stack_sp);
4182 while (PL_scopestack_ix > oldscopeix) {
4185 leave_scope(oldsaveix);
4190 sortcv_stacked(pTHXo_ SV *a, SV *b)
4192 I32 oldsaveix = PL_savestack_ix;
4193 I32 oldscopeix = PL_scopestack_ix;
4198 av = (AV*)PL_curpad[0];
4200 av = GvAV(PL_defgv);
4203 if (AvMAX(av) < 1) {
4204 SV** ary = AvALLOC(av);
4205 if (AvARRAY(av) != ary) {
4206 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4207 SvPVX(av) = (char*)ary;
4209 if (AvMAX(av) < 1) {
4212 SvPVX(av) = (char*)ary;
4219 PL_stack_sp = PL_stack_base;
4222 if (PL_stack_sp != PL_stack_base + 1)
4223 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4224 if (!SvNIOKp(*PL_stack_sp))
4225 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4226 result = SvIV(*PL_stack_sp);
4227 while (PL_scopestack_ix > oldscopeix) {
4230 leave_scope(oldsaveix);
4235 sortcv_xsub(pTHXo_ SV *a, SV *b)
4238 I32 oldsaveix = PL_savestack_ix;
4239 I32 oldscopeix = PL_scopestack_ix;
4241 CV *cv=(CV*)PL_sortcop;
4249 (void)(*CvXSUB(cv))(aTHXo_ cv);
4250 if (PL_stack_sp != PL_stack_base + 1)
4251 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4252 if (!SvNIOKp(*PL_stack_sp))
4253 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4254 result = SvIV(*PL_stack_sp);
4255 while (PL_scopestack_ix > oldscopeix) {
4258 leave_scope(oldsaveix);
4264 sv_ncmp(pTHXo_ SV *a, SV *b)
4268 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4272 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4276 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4278 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4280 if (PL_amagic_generation) { \
4281 if (SvAMAGIC(left)||SvAMAGIC(right))\
4282 *svp = amagic_call(left, \
4290 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4293 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4298 I32 i = SvIVX(tmpsv);
4308 return sv_ncmp(aTHXo_ a, b);
4312 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4315 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4320 I32 i = SvIVX(tmpsv);
4330 return sv_i_ncmp(aTHXo_ a, b);
4334 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4337 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4342 I32 i = SvIVX(tmpsv);
4352 return sv_cmp(str1, str2);
4356 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4359 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4364 I32 i = SvIVX(tmpsv);
4374 return sv_cmp_locale(str1, str2);
4378 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4380 SV *datasv = FILTER_DATA(idx);
4381 int filter_has_file = IoLINES(datasv);
4382 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4383 SV *filter_state = (SV *)IoTOP_GV(datasv);
4384 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4387 /* I was having segfault trouble under Linux 2.2.5 after a
4388 parse error occured. (Had to hack around it with a test
4389 for PL_error_count == 0.) Solaris doesn't segfault --
4390 not sure where the trouble is yet. XXX */
4392 if (filter_has_file) {
4393 len = FILTER_READ(idx+1, buf_sv, maxlen);
4396 if (filter_sub && len >= 0) {
4407 PUSHs(sv_2mortal(newSViv(maxlen)));
4409 PUSHs(filter_state);
4412 count = call_sv(filter_sub, G_SCALAR);
4428 IoLINES(datasv) = 0;
4429 if (filter_child_proc) {
4430 SvREFCNT_dec(filter_child_proc);
4431 IoFMT_GV(datasv) = Nullgv;
4434 SvREFCNT_dec(filter_state);
4435 IoTOP_GV(datasv) = Nullgv;
4438 SvREFCNT_dec(filter_sub);
4439 IoBOTTOM_GV(datasv) = Nullgv;
4441 filter_del(run_user_filter);
4450 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4452 return sv_cmp_locale(str1, str2);
4456 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4458 return sv_cmp(str1, str2);
4461 #endif /* PERL_OBJECT */