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 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, PERL_MAGIC_qr);
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
118 pm->op_pmdynflags |= PMdf_DYN_UTF8;
120 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
121 if (pm->op_pmdynflags & PMdf_UTF8)
122 t = (char*)bytes_to_utf8((U8*)t, &len);
124 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
125 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
127 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
128 inside tie/overload accessors. */
132 #ifndef INCOMPLETE_TAINTS
135 pm->op_pmdynflags |= PMdf_TAINTED;
137 pm->op_pmdynflags &= ~PMdf_TAINTED;
141 if (!pm->op_pmregexp->prelen && PL_curpm)
143 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
144 pm->op_pmflags |= PMf_WHITE;
146 /* XXX runtime compiled output needs to move to the pad */
147 if (pm->op_pmflags & PMf_KEEP) {
148 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
149 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
150 /* XXX can't change the optree at runtime either */
151 cLOGOP->op_first->op_next = PL_op->op_next;
160 register PMOP *pm = (PMOP*) cLOGOP->op_other;
161 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
162 register SV *dstr = cx->sb_dstr;
163 register char *s = cx->sb_s;
164 register char *m = cx->sb_m;
165 char *orig = cx->sb_orig;
166 register REGEXP *rx = cx->sb_rx;
168 rxres_restore(&cx->sb_rxres, rx);
170 if (cx->sb_iters++) {
171 if (cx->sb_iters > cx->sb_maxiters)
172 DIE(aTHX_ "Substitution loop");
174 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
175 cx->sb_rxtainted |= 2;
176 sv_catsv(dstr, POPs);
179 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
180 s == m, cx->sb_targ, NULL,
181 ((cx->sb_rflags & REXEC_COPY_STR)
182 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
183 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
185 SV *targ = cx->sb_targ;
187 sv_catpvn(dstr, s, cx->sb_strend - s);
188 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
190 (void)SvOOK_off(targ);
191 Safefree(SvPVX(targ));
192 SvPVX(targ) = SvPVX(dstr);
193 SvCUR_set(targ, SvCUR(dstr));
194 SvLEN_set(targ, SvLEN(dstr));
200 TAINT_IF(cx->sb_rxtainted & 1);
201 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
203 (void)SvPOK_only_UTF8(targ);
204 TAINT_IF(cx->sb_rxtainted);
208 LEAVE_SCOPE(cx->sb_oldsave);
210 RETURNOP(pm->op_next);
213 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
216 cx->sb_orig = orig = rx->subbeg;
218 cx->sb_strend = s + (cx->sb_strend - m);
220 cx->sb_m = m = rx->startp[0] + orig;
222 sv_catpvn(dstr, s, m-s);
223 cx->sb_s = rx->endp[0] + orig;
224 { /* Update the pos() information. */
225 SV *sv = cx->sb_targ;
228 if (SvTYPE(sv) < SVt_PVMG)
229 (void)SvUPGRADE(sv, SVt_PVMG);
230 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
231 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
232 mg = mg_find(sv, PERL_MAGIC_regex_global);
239 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
240 rxres_save(&cx->sb_rxres, rx);
241 RETURNOP(pm->op_pmreplstart);
245 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
250 if (!p || p[1] < rx->nparens) {
251 i = 6 + rx->nparens * 2;
259 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
260 RX_MATCH_COPIED_off(rx);
264 *p++ = PTR2UV(rx->subbeg);
265 *p++ = (UV)rx->sublen;
266 for (i = 0; i <= rx->nparens; ++i) {
267 *p++ = (UV)rx->startp[i];
268 *p++ = (UV)rx->endp[i];
273 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
278 if (RX_MATCH_COPIED(rx))
279 Safefree(rx->subbeg);
280 RX_MATCH_COPIED_set(rx, *p);
285 rx->subbeg = INT2PTR(char*,*p++);
286 rx->sublen = (I32)(*p++);
287 for (i = 0; i <= rx->nparens; ++i) {
288 rx->startp[i] = (I32)(*p++);
289 rx->endp[i] = (I32)(*p++);
294 Perl_rxres_free(pTHX_ void **rsp)
299 Safefree(INT2PTR(char*,*p));
307 dSP; dMARK; dORIGMARK;
308 register SV *tmpForm = *++MARK;
315 register SV *sv = Nullsv;
320 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
321 char *chophere = Nullch;
322 char *linemark = Nullch;
324 bool gotsome = FALSE;
326 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
327 bool item_is_utf = FALSE;
329 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
330 if (SvREADONLY(tmpForm)) {
331 SvREADONLY_off(tmpForm);
332 doparseform(tmpForm);
333 SvREADONLY_on(tmpForm);
336 doparseform(tmpForm);
339 SvPV_force(PL_formtarget, len);
340 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
342 f = SvPV(tmpForm, len);
343 /* need to jump to the next word */
344 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
353 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
354 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
355 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
356 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
357 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
359 case FF_CHECKNL: name = "CHECKNL"; break;
360 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
361 case FF_SPACE: name = "SPACE"; break;
362 case FF_HALFSPACE: name = "HALFSPACE"; break;
363 case FF_ITEM: name = "ITEM"; break;
364 case FF_CHOP: name = "CHOP"; break;
365 case FF_LINEGLOB: name = "LINEGLOB"; break;
366 case FF_NEWLINE: name = "NEWLINE"; break;
367 case FF_MORE: name = "MORE"; break;
368 case FF_LINEMARK: name = "LINEMARK"; break;
369 case FF_END: name = "END"; break;
370 case FF_0DECIMAL: name = "0DECIMAL"; break;
373 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
375 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
403 if (ckWARN(WARN_SYNTAX))
404 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
409 item = s = SvPV(sv, len);
412 itemsize = sv_len_utf8(sv);
413 if (itemsize != len) {
415 if (itemsize > fieldsize) {
416 itemsize = fieldsize;
417 itembytes = itemsize;
418 sv_pos_u2b(sv, &itembytes, 0);
422 send = chophere = s + itembytes;
432 sv_pos_b2u(sv, &itemsize);
437 if (itemsize > fieldsize)
438 itemsize = fieldsize;
439 send = chophere = s + itemsize;
451 item = s = SvPV(sv, len);
454 itemsize = sv_len_utf8(sv);
455 if (itemsize != len) {
457 if (itemsize <= fieldsize) {
458 send = chophere = s + itemsize;
469 itemsize = fieldsize;
470 itembytes = itemsize;
471 sv_pos_u2b(sv, &itembytes, 0);
472 send = chophere = s + itembytes;
473 while (s < send || (s == send && isSPACE(*s))) {
483 if (strchr(PL_chopset, *s))
488 itemsize = chophere - item;
489 sv_pos_b2u(sv, &itemsize);
496 if (itemsize <= fieldsize) {
497 send = chophere = s + itemsize;
508 itemsize = fieldsize;
509 send = chophere = s + itemsize;
510 while (s < send || (s == send && isSPACE(*s))) {
520 if (strchr(PL_chopset, *s))
525 itemsize = chophere - item;
530 arg = fieldsize - itemsize;
539 arg = fieldsize - itemsize;
553 if (UTF8_IS_CONTINUED(*s)) {
554 STRLEN skip = UTF8SKIP(s);
571 if ( !((*t++ = *s++) & ~31) )
579 int ch = *t++ = *s++;
582 if ( !((*t++ = *s++) & ~31) )
591 while (*s && isSPACE(*s))
598 item = s = SvPV(sv, len);
600 item_is_utf = FALSE; /* XXX is this correct? */
612 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
613 sv_catpvn(PL_formtarget, item, itemsize);
614 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
615 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
620 /* If the field is marked with ^ and the value is undefined,
623 if ((arg & 512) && !SvOK(sv)) {
631 /* Formats aren't yet marked for locales, so assume "yes". */
633 STORE_NUMERIC_STANDARD_SET_LOCAL();
634 #if defined(USE_LONG_DOUBLE)
636 sprintf(t, "%#*.*" PERL_PRIfldbl,
637 (int) fieldsize, (int) arg & 255, value);
639 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
644 (int) fieldsize, (int) arg & 255, value);
647 (int) fieldsize, value);
650 RESTORE_NUMERIC_STANDARD();
656 /* If the field is marked with ^ and the value is undefined,
659 if ((arg & 512) && !SvOK(sv)) {
667 /* Formats aren't yet marked for locales, so assume "yes". */
669 STORE_NUMERIC_STANDARD_SET_LOCAL();
670 #if defined(USE_LONG_DOUBLE)
672 sprintf(t, "%#0*.*" PERL_PRIfldbl,
673 (int) fieldsize, (int) arg & 255, value);
674 /* is this legal? I don't have long doubles */
676 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
680 sprintf(t, "%#0*.*f",
681 (int) fieldsize, (int) arg & 255, value);
684 (int) fieldsize, value);
687 RESTORE_NUMERIC_STANDARD();
694 while (t-- > linemark && *t == ' ') ;
702 if (arg) { /* repeat until fields exhausted? */
704 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
705 lines += FmLINES(PL_formtarget);
708 if (strnEQ(linemark, linemark - arg, arg))
709 DIE(aTHX_ "Runaway format");
711 FmLINES(PL_formtarget) = lines;
713 RETURNOP(cLISTOP->op_first);
726 while (*s && isSPACE(*s) && s < send)
730 arg = fieldsize - itemsize;
737 if (strnEQ(s," ",3)) {
738 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
749 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
750 FmLINES(PL_formtarget) += lines;
762 if (PL_stack_base + *PL_markstack_ptr == SP) {
764 if (GIMME_V == G_SCALAR)
765 XPUSHs(sv_2mortal(newSViv(0)));
766 RETURNOP(PL_op->op_next->op_next);
768 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
769 pp_pushmark(); /* push dst */
770 pp_pushmark(); /* push src */
771 ENTER; /* enter outer scope */
774 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
776 ENTER; /* enter inner scope */
779 src = PL_stack_base[*PL_markstack_ptr];
784 if (PL_op->op_type == OP_MAPSTART)
785 pp_pushmark(); /* push top */
786 return ((LOGOP*)PL_op->op_next)->op_other;
791 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
797 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
803 /* first, move source pointer to the next item in the source list */
804 ++PL_markstack_ptr[-1];
806 /* if there are new items, push them into the destination list */
808 /* might need to make room back there first */
809 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
810 /* XXX this implementation is very pessimal because the stack
811 * is repeatedly extended for every set of items. Is possible
812 * to do this without any stack extension or copying at all
813 * by maintaining a separate list over which the map iterates
814 * (like foreach does). --gsar */
816 /* everything in the stack after the destination list moves
817 * towards the end the stack by the amount of room needed */
818 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
820 /* items to shift up (accounting for the moved source pointer) */
821 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
823 /* This optimization is by Ben Tilly and it does
824 * things differently from what Sarathy (gsar)
825 * is describing. The downside of this optimization is
826 * that leaves "holes" (uninitialized and hopefully unused areas)
827 * to the Perl stack, but on the other hand this
828 * shouldn't be a problem. If Sarathy's idea gets
829 * implemented, this optimization should become
830 * irrelevant. --jhi */
832 shift = count; /* Avoid shifting too often --Ben Tilly */
837 PL_markstack_ptr[-1] += shift;
838 *PL_markstack_ptr += shift;
842 /* copy the new items down to the destination list */
843 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
845 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
847 LEAVE; /* exit inner scope */
850 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
853 (void)POPMARK; /* pop top */
854 LEAVE; /* exit outer scope */
855 (void)POPMARK; /* pop src */
856 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
857 (void)POPMARK; /* pop dst */
858 SP = PL_stack_base + POPMARK; /* pop original mark */
859 if (gimme == G_SCALAR) {
863 else if (gimme == G_ARRAY)
870 ENTER; /* enter inner scope */
873 /* set $_ to the new source item */
874 src = PL_stack_base[PL_markstack_ptr[-1]];
878 RETURNOP(cLOGOP->op_other);
884 dSP; dMARK; dORIGMARK;
886 SV **myorigmark = ORIGMARK;
892 OP* nextop = PL_op->op_next;
894 bool hasargs = FALSE;
897 if (gimme != G_ARRAY) {
903 SAVEVPTR(PL_sortcop);
904 if (PL_op->op_flags & OPf_STACKED) {
905 if (PL_op->op_flags & OPf_SPECIAL) {
906 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
907 kid = kUNOP->op_first; /* pass rv2gv */
908 kid = kUNOP->op_first; /* pass leave */
909 PL_sortcop = kid->op_next;
910 stash = CopSTASH(PL_curcop);
913 cv = sv_2cv(*++MARK, &stash, &gv, 0);
914 if (cv && SvPOK(cv)) {
916 char *proto = SvPV((SV*)cv, n_a);
917 if (proto && strEQ(proto, "$$")) {
921 if (!(cv && CvROOT(cv))) {
922 if (cv && CvXSUB(cv)) {
926 SV *tmpstr = sv_newmortal();
927 gv_efullname3(tmpstr, gv, Nullch);
928 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
932 DIE(aTHX_ "Undefined subroutine in sort");
937 PL_sortcop = (OP*)cv;
939 PL_sortcop = CvSTART(cv);
940 SAVEVPTR(CvROOT(cv)->op_ppaddr);
941 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
944 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
950 stash = CopSTASH(PL_curcop);
954 while (MARK < SP) { /* This may or may not shift down one here. */
956 if ((*up = *++MARK)) { /* Weed out nulls. */
958 if (!PL_sortcop && !SvPOK(*up)) {
963 (void)sv_2pv(*up, &n_a);
968 max = --up - myorigmark;
973 bool oldcatch = CATCH_GET;
979 PUSHSTACKi(PERLSI_SORT);
980 if (!hasargs && !is_xsub) {
981 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
982 SAVESPTR(PL_firstgv);
983 SAVESPTR(PL_secondgv);
984 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
985 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
986 PL_sortstash = stash;
989 sv_lock((SV *)PL_firstgv);
990 sv_lock((SV *)PL_secondgv);
992 SAVESPTR(GvSV(PL_firstgv));
993 SAVESPTR(GvSV(PL_secondgv));
996 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
997 if (!(PL_op->op_flags & OPf_SPECIAL)) {
998 cx->cx_type = CXt_SUB;
999 cx->blk_gimme = G_SCALAR;
1002 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1004 PL_sortcxix = cxstack_ix;
1006 if (hasargs && !is_xsub) {
1007 /* This is mostly copied from pp_entersub */
1008 AV *av = (AV*)PL_curpad[0];
1011 cx->blk_sub.savearray = GvAV(PL_defgv);
1012 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1013 #endif /* USE_THREADS */
1014 cx->blk_sub.oldcurpad = PL_curpad;
1015 cx->blk_sub.argarray = av;
1017 qsortsv((myorigmark+1), max,
1018 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1020 POPBLOCK(cx,PL_curpm);
1021 PL_stack_sp = newsp;
1023 CATCH_SET(oldcatch);
1028 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1029 qsortsv(ORIGMARK+1, max,
1030 (PL_op->op_private & OPpSORT_NUMERIC)
1031 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1032 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1033 : ( overloading ? amagic_ncmp : sv_ncmp))
1034 : ( (PL_op->op_private & OPpLOCALE)
1037 : sv_cmp_locale_static)
1038 : ( overloading ? amagic_cmp : sv_cmp_static)));
1039 if (PL_op->op_private & OPpSORT_REVERSE) {
1040 SV **p = ORIGMARK+1;
1041 SV **q = ORIGMARK+max;
1051 PL_stack_sp = ORIGMARK + max;
1059 if (GIMME == G_ARRAY)
1061 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1062 return cLOGOP->op_other;
1071 if (GIMME == G_ARRAY) {
1072 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1076 SV *targ = PAD_SV(PL_op->op_targ);
1079 if (PL_op->op_private & OPpFLIP_LINENUM) {
1081 flip = PL_last_in_gv
1082 && (gp_io = GvIO(PL_last_in_gv))
1083 && SvIV(sv) == (IV)IoLINES(gp_io);
1088 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1089 if (PL_op->op_flags & OPf_SPECIAL) {
1097 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1110 if (GIMME == G_ARRAY) {
1116 if (SvGMAGICAL(left))
1118 if (SvGMAGICAL(right))
1121 if (SvNIOKp(left) || !SvPOKp(left) ||
1122 SvNIOKp(right) || !SvPOKp(right) ||
1123 (looks_like_number(left) && *SvPVX(left) != '0' &&
1124 looks_like_number(right) && *SvPVX(right) != '0'))
1126 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1127 DIE(aTHX_ "Range iterator outside integer range");
1138 sv = sv_2mortal(newSViv(i++));
1143 SV *final = sv_mortalcopy(right);
1145 char *tmps = SvPV(final, len);
1147 sv = sv_mortalcopy(left);
1149 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1151 if (strEQ(SvPVX(sv),tmps))
1153 sv = sv_2mortal(newSVsv(sv));
1160 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1162 if ((PL_op->op_private & OPpFLIP_LINENUM)
1163 ? (GvIO(PL_last_in_gv)
1164 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1166 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1167 sv_catpv(targ, "E0");
1178 S_dopoptolabel(pTHX_ char *label)
1181 register PERL_CONTEXT *cx;
1183 for (i = cxstack_ix; i >= 0; i--) {
1185 switch (CxTYPE(cx)) {
1187 if (ckWARN(WARN_EXITING))
1188 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1189 PL_op_name[PL_op->op_type]);
1192 if (ckWARN(WARN_EXITING))
1193 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1194 PL_op_name[PL_op->op_type]);
1197 if (ckWARN(WARN_EXITING))
1198 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1199 PL_op_name[PL_op->op_type]);
1202 if (ckWARN(WARN_EXITING))
1203 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1204 PL_op_name[PL_op->op_type]);
1207 if (ckWARN(WARN_EXITING))
1208 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1209 PL_op_name[PL_op->op_type]);
1212 if (!cx->blk_loop.label ||
1213 strNE(label, cx->blk_loop.label) ) {
1214 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1215 (long)i, cx->blk_loop.label));
1218 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1226 Perl_dowantarray(pTHX)
1228 I32 gimme = block_gimme();
1229 return (gimme == G_VOID) ? G_SCALAR : gimme;
1233 Perl_block_gimme(pTHX)
1237 cxix = dopoptosub(cxstack_ix);
1241 switch (cxstack[cxix].blk_gimme) {
1249 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1256 Perl_is_lvalue_sub(pTHX)
1260 cxix = dopoptosub(cxstack_ix);
1261 assert(cxix >= 0); /* We should only be called from inside subs */
1263 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1264 return cxstack[cxix].blk_sub.lval;
1270 S_dopoptosub(pTHX_ I32 startingblock)
1272 return dopoptosub_at(cxstack, startingblock);
1276 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1279 register PERL_CONTEXT *cx;
1280 for (i = startingblock; i >= 0; i--) {
1282 switch (CxTYPE(cx)) {
1288 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1296 S_dopoptoeval(pTHX_ I32 startingblock)
1299 register PERL_CONTEXT *cx;
1300 for (i = startingblock; i >= 0; i--) {
1302 switch (CxTYPE(cx)) {
1306 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1314 S_dopoptoloop(pTHX_ I32 startingblock)
1317 register PERL_CONTEXT *cx;
1318 for (i = startingblock; i >= 0; i--) {
1320 switch (CxTYPE(cx)) {
1322 if (ckWARN(WARN_EXITING))
1323 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1324 PL_op_name[PL_op->op_type]);
1327 if (ckWARN(WARN_EXITING))
1328 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1329 PL_op_name[PL_op->op_type]);
1332 if (ckWARN(WARN_EXITING))
1333 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1334 PL_op_name[PL_op->op_type]);
1337 if (ckWARN(WARN_EXITING))
1338 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1339 PL_op_name[PL_op->op_type]);
1342 if (ckWARN(WARN_EXITING))
1343 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1344 PL_op_name[PL_op->op_type]);
1347 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1355 Perl_dounwind(pTHX_ I32 cxix)
1357 register PERL_CONTEXT *cx;
1360 while (cxstack_ix > cxix) {
1362 cx = &cxstack[cxstack_ix];
1363 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1364 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1365 /* Note: we don't need to restore the base context info till the end. */
1366 switch (CxTYPE(cx)) {
1369 continue; /* not break */
1391 Perl_qerror(pTHX_ SV *err)
1394 sv_catsv(ERRSV, err);
1396 sv_catsv(PL_errors, err);
1398 Perl_warn(aTHX_ "%"SVf, err);
1403 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1408 register PERL_CONTEXT *cx;
1413 if (PL_in_eval & EVAL_KEEPERR) {
1414 static char prefix[] = "\t(in cleanup) ";
1419 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1422 if (*e != *message || strNE(e,message))
1426 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1427 sv_catpvn(err, prefix, sizeof(prefix)-1);
1428 sv_catpvn(err, message, msglen);
1429 if (ckWARN(WARN_MISC)) {
1430 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1431 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1436 sv_setpvn(ERRSV, message, msglen);
1440 message = SvPVx(ERRSV, msglen);
1442 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1443 && PL_curstackinfo->si_prev)
1452 if (cxix < cxstack_ix)
1455 POPBLOCK(cx,PL_curpm);
1456 if (CxTYPE(cx) != CXt_EVAL) {
1457 PerlIO_write(Perl_error_log, "panic: die ", 11);
1458 PerlIO_write(Perl_error_log, message, msglen);
1463 if (gimme == G_SCALAR)
1464 *++newsp = &PL_sv_undef;
1465 PL_stack_sp = newsp;
1469 /* LEAVE could clobber PL_curcop (see save_re_context())
1470 * XXX it might be better to find a way to avoid messing with
1471 * PL_curcop in save_re_context() instead, but this is a more
1472 * minimal fix --GSAR */
1473 PL_curcop = cx->blk_oldcop;
1475 if (optype == OP_REQUIRE) {
1476 char* msg = SvPVx(ERRSV, n_a);
1477 DIE(aTHX_ "%sCompilation failed in require",
1478 *msg ? msg : "Unknown error\n");
1480 return pop_return();
1484 message = SvPVx(ERRSV, msglen);
1487 /* SFIO can really mess with your errno */
1490 PerlIO *serr = Perl_error_log;
1492 PerlIO_write(serr, message, msglen);
1493 (void)PerlIO_flush(serr);
1506 if (SvTRUE(left) != SvTRUE(right))
1518 RETURNOP(cLOGOP->op_other);
1527 RETURNOP(cLOGOP->op_other);
1533 register I32 cxix = dopoptosub(cxstack_ix);
1534 register PERL_CONTEXT *cx;
1535 register PERL_CONTEXT *ccstack = cxstack;
1536 PERL_SI *top_si = PL_curstackinfo;
1547 /* we may be in a higher stacklevel, so dig down deeper */
1548 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1549 top_si = top_si->si_prev;
1550 ccstack = top_si->si_cxstack;
1551 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1554 if (GIMME != G_ARRAY)
1558 if (PL_DBsub && cxix >= 0 &&
1559 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1563 cxix = dopoptosub_at(ccstack, cxix - 1);
1566 cx = &ccstack[cxix];
1567 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1568 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1569 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1570 field below is defined for any cx. */
1571 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1572 cx = &ccstack[dbcxix];
1575 stashname = CopSTASHPV(cx->blk_oldcop);
1576 if (GIMME != G_ARRAY) {
1578 PUSHs(&PL_sv_undef);
1581 sv_setpv(TARG, stashname);
1588 PUSHs(&PL_sv_undef);
1590 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1591 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1592 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1595 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1596 /* So is ccstack[dbcxix]. */
1598 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1599 PUSHs(sv_2mortal(sv));
1600 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1603 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1604 PUSHs(sv_2mortal(newSViv(0)));
1606 gimme = (I32)cx->blk_gimme;
1607 if (gimme == G_VOID)
1608 PUSHs(&PL_sv_undef);
1610 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1611 if (CxTYPE(cx) == CXt_EVAL) {
1613 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1614 PUSHs(cx->blk_eval.cur_text);
1618 else if (cx->blk_eval.old_namesv) {
1619 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1622 /* eval BLOCK (try blocks have old_namesv == 0) */
1624 PUSHs(&PL_sv_undef);
1625 PUSHs(&PL_sv_undef);
1629 PUSHs(&PL_sv_undef);
1630 PUSHs(&PL_sv_undef);
1632 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1633 && CopSTASH_eq(PL_curcop, PL_debstash))
1635 AV *ary = cx->blk_sub.argarray;
1636 int off = AvARRAY(ary) - AvALLOC(ary);
1640 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1643 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1646 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1647 av_extend(PL_dbargs, AvFILLp(ary) + off);
1648 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1649 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1651 /* XXX only hints propagated via op_private are currently
1652 * visible (others are not easily accessible, since they
1653 * use the global PL_hints) */
1654 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1655 HINT_PRIVATE_MASK)));
1658 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1660 if (old_warnings == pWARN_NONE ||
1661 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1662 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1663 else if (old_warnings == pWARN_ALL ||
1664 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1665 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1667 mask = newSVsv(old_warnings);
1668 PUSHs(sv_2mortal(mask));
1683 sv_reset(tmps, CopSTASH(PL_curcop));
1695 PL_curcop = (COP*)PL_op;
1696 TAINT_NOT; /* Each statement is presumed innocent */
1697 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1700 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1704 register PERL_CONTEXT *cx;
1705 I32 gimme = G_ARRAY;
1712 DIE(aTHX_ "No DB::DB routine defined");
1714 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1715 /* don't do recursive DB::DB call */
1727 push_return(PL_op->op_next);
1728 PUSHBLOCK(cx, CXt_SUB, SP);
1731 (void)SvREFCNT_inc(cv);
1732 SAVEVPTR(PL_curpad);
1733 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1734 RETURNOP(CvSTART(cv));
1748 register PERL_CONTEXT *cx;
1749 I32 gimme = GIMME_V;
1751 U32 cxtype = CXt_LOOP;
1760 if (PL_op->op_flags & OPf_SPECIAL) {
1761 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1762 SAVEGENERICSV(*svp);
1766 #endif /* USE_THREADS */
1767 if (PL_op->op_targ) {
1768 #ifndef USE_ITHREADS
1769 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1772 SAVEPADSV(PL_op->op_targ);
1773 iterdata = (void*)PL_op->op_targ;
1774 cxtype |= CXp_PADVAR;
1779 svp = &GvSV(gv); /* symbol table variable */
1780 SAVEGENERICSV(*svp);
1783 iterdata = (void*)gv;
1789 PUSHBLOCK(cx, cxtype, SP);
1791 PUSHLOOP(cx, iterdata, MARK);
1793 PUSHLOOP(cx, svp, MARK);
1795 if (PL_op->op_flags & OPf_STACKED) {
1796 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1797 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1799 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1800 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1801 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1802 looks_like_number((SV*)cx->blk_loop.iterary) &&
1803 *SvPVX(cx->blk_loop.iterary) != '0'))
1805 if (SvNV(sv) < IV_MIN ||
1806 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1807 DIE(aTHX_ "Range iterator outside integer range");
1808 cx->blk_loop.iterix = SvIV(sv);
1809 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1812 cx->blk_loop.iterlval = newSVsv(sv);
1816 cx->blk_loop.iterary = PL_curstack;
1817 AvFILLp(PL_curstack) = SP - PL_stack_base;
1818 cx->blk_loop.iterix = MARK - PL_stack_base;
1827 register PERL_CONTEXT *cx;
1828 I32 gimme = GIMME_V;
1834 PUSHBLOCK(cx, CXt_LOOP, SP);
1835 PUSHLOOP(cx, 0, SP);
1843 register PERL_CONTEXT *cx;
1851 newsp = PL_stack_base + cx->blk_loop.resetsp;
1854 if (gimme == G_VOID)
1856 else if (gimme == G_SCALAR) {
1858 *++newsp = sv_mortalcopy(*SP);
1860 *++newsp = &PL_sv_undef;
1864 *++newsp = sv_mortalcopy(*++mark);
1865 TAINT_NOT; /* Each item is independent */
1871 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1872 PL_curpm = newpm; /* ... and pop $1 et al */
1884 register PERL_CONTEXT *cx;
1885 bool popsub2 = FALSE;
1886 bool clear_errsv = FALSE;
1893 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1894 if (cxstack_ix == PL_sortcxix
1895 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1897 if (cxstack_ix > PL_sortcxix)
1898 dounwind(PL_sortcxix);
1899 AvARRAY(PL_curstack)[1] = *SP;
1900 PL_stack_sp = PL_stack_base + 1;
1905 cxix = dopoptosub(cxstack_ix);
1907 DIE(aTHX_ "Can't return outside a subroutine");
1908 if (cxix < cxstack_ix)
1912 switch (CxTYPE(cx)) {
1917 if (!(PL_in_eval & EVAL_KEEPERR))
1923 if (optype == OP_REQUIRE &&
1924 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1926 /* Unassume the success we assumed earlier. */
1927 SV *nsv = cx->blk_eval.old_namesv;
1928 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1929 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1936 DIE(aTHX_ "panic: return");
1940 if (gimme == G_SCALAR) {
1943 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1945 *++newsp = SvREFCNT_inc(*SP);
1950 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1952 *++newsp = sv_mortalcopy(sv);
1957 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1960 *++newsp = sv_mortalcopy(*SP);
1963 *++newsp = &PL_sv_undef;
1965 else if (gimme == G_ARRAY) {
1966 while (++MARK <= SP) {
1967 *++newsp = (popsub2 && SvTEMP(*MARK))
1968 ? *MARK : sv_mortalcopy(*MARK);
1969 TAINT_NOT; /* Each item is independent */
1972 PL_stack_sp = newsp;
1974 /* Stack values are safe: */
1976 POPSUB(cx,sv); /* release CV and @_ ... */
1980 PL_curpm = newpm; /* ... and pop $1 et al */
1986 return pop_return();
1993 register PERL_CONTEXT *cx;
2003 if (PL_op->op_flags & OPf_SPECIAL) {
2004 cxix = dopoptoloop(cxstack_ix);
2006 DIE(aTHX_ "Can't \"last\" outside a loop block");
2009 cxix = dopoptolabel(cPVOP->op_pv);
2011 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2013 if (cxix < cxstack_ix)
2018 switch (CxTYPE(cx)) {
2021 newsp = PL_stack_base + cx->blk_loop.resetsp;
2022 nextop = cx->blk_loop.last_op->op_next;
2026 nextop = pop_return();
2030 nextop = pop_return();
2034 nextop = pop_return();
2037 DIE(aTHX_ "panic: last");
2041 if (gimme == G_SCALAR) {
2043 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2044 ? *SP : sv_mortalcopy(*SP);
2046 *++newsp = &PL_sv_undef;
2048 else if (gimme == G_ARRAY) {
2049 while (++MARK <= SP) {
2050 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2051 ? *MARK : sv_mortalcopy(*MARK);
2052 TAINT_NOT; /* Each item is independent */
2058 /* Stack values are safe: */
2061 POPLOOP(cx); /* release loop vars ... */
2065 POPSUB(cx,sv); /* release CV and @_ ... */
2068 PL_curpm = newpm; /* ... and pop $1 et al */
2078 register PERL_CONTEXT *cx;
2081 if (PL_op->op_flags & OPf_SPECIAL) {
2082 cxix = dopoptoloop(cxstack_ix);
2084 DIE(aTHX_ "Can't \"next\" outside a loop block");
2087 cxix = dopoptolabel(cPVOP->op_pv);
2089 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2091 if (cxix < cxstack_ix)
2094 /* clear off anything above the scope we're re-entering, but
2095 * save the rest until after a possible continue block */
2096 inner = PL_scopestack_ix;
2098 if (PL_scopestack_ix < inner)
2099 leave_scope(PL_scopestack[PL_scopestack_ix]);
2100 return cx->blk_loop.next_op;
2106 register PERL_CONTEXT *cx;
2109 if (PL_op->op_flags & OPf_SPECIAL) {
2110 cxix = dopoptoloop(cxstack_ix);
2112 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2115 cxix = dopoptolabel(cPVOP->op_pv);
2117 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2119 if (cxix < cxstack_ix)
2123 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2124 LEAVE_SCOPE(oldsave);
2125 return cx->blk_loop.redo_op;
2129 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2133 static char too_deep[] = "Target of goto is too deeply nested";
2136 Perl_croak(aTHX_ too_deep);
2137 if (o->op_type == OP_LEAVE ||
2138 o->op_type == OP_SCOPE ||
2139 o->op_type == OP_LEAVELOOP ||
2140 o->op_type == OP_LEAVETRY)
2142 *ops++ = cUNOPo->op_first;
2144 Perl_croak(aTHX_ too_deep);
2147 if (o->op_flags & OPf_KIDS) {
2148 /* First try all the kids at this level, since that's likeliest. */
2149 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2150 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2151 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2154 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2155 if (kid == PL_lastgotoprobe)
2157 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2159 (ops[-1]->op_type != OP_NEXTSTATE &&
2160 ops[-1]->op_type != OP_DBSTATE)))
2162 if ((o = dofindlabel(kid, label, ops, oplimit)))
2181 register PERL_CONTEXT *cx;
2182 #define GOTO_DEPTH 64
2183 OP *enterops[GOTO_DEPTH];
2185 int do_dump = (PL_op->op_type == OP_DUMP);
2186 static char must_have_label[] = "goto must have label";
2189 if (PL_op->op_flags & OPf_STACKED) {
2193 /* This egregious kludge implements goto &subroutine */
2194 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2196 register PERL_CONTEXT *cx;
2197 CV* cv = (CV*)SvRV(sv);
2203 if (!CvROOT(cv) && !CvXSUB(cv)) {
2208 /* autoloaded stub? */
2209 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2211 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2212 GvNAMELEN(gv), FALSE);
2213 if (autogv && (cv = GvCV(autogv)))
2215 tmpstr = sv_newmortal();
2216 gv_efullname3(tmpstr, gv, Nullch);
2217 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2219 DIE(aTHX_ "Goto undefined subroutine");
2222 /* First do some returnish stuff. */
2223 cxix = dopoptosub(cxstack_ix);
2225 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2226 if (cxix < cxstack_ix)
2230 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2232 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2233 /* put @_ back onto stack */
2234 AV* av = cx->blk_sub.argarray;
2236 items = AvFILLp(av) + 1;
2238 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2239 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2240 PL_stack_sp += items;
2242 SvREFCNT_dec(GvAV(PL_defgv));
2243 GvAV(PL_defgv) = cx->blk_sub.savearray;
2244 #endif /* USE_THREADS */
2245 /* abandon @_ if it got reified */
2247 (void)sv_2mortal((SV*)av); /* delay until return */
2249 av_extend(av, items-1);
2250 AvFLAGS(av) = AVf_REIFY;
2251 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2254 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2257 av = (AV*)PL_curpad[0];
2259 av = GvAV(PL_defgv);
2261 items = AvFILLp(av) + 1;
2263 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2264 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2265 PL_stack_sp += items;
2267 if (CxTYPE(cx) == CXt_SUB &&
2268 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2269 SvREFCNT_dec(cx->blk_sub.cv);
2270 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2271 LEAVE_SCOPE(oldsave);
2273 /* Now do some callish stuff. */
2276 #ifdef PERL_XSUB_OLDSTYLE
2277 if (CvOLDSTYLE(cv)) {
2278 I32 (*fp3)(int,int,int);
2283 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2284 items = (*fp3)(CvXSUBANY(cv).any_i32,
2285 mark - PL_stack_base + 1,
2287 SP = PL_stack_base + items;
2290 #endif /* PERL_XSUB_OLDSTYLE */
2295 PL_stack_sp--; /* There is no cv arg. */
2296 /* Push a mark for the start of arglist */
2298 (void)(*CvXSUB(cv))(aTHXo_ cv);
2299 /* Pop the current context like a decent sub should */
2300 POPBLOCK(cx, PL_curpm);
2301 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2304 return pop_return();
2307 AV* padlist = CvPADLIST(cv);
2308 SV** svp = AvARRAY(padlist);
2309 if (CxTYPE(cx) == CXt_EVAL) {
2310 PL_in_eval = cx->blk_eval.old_in_eval;
2311 PL_eval_root = cx->blk_eval.old_eval_root;
2312 cx->cx_type = CXt_SUB;
2313 cx->blk_sub.hasargs = 0;
2315 cx->blk_sub.cv = cv;
2316 cx->blk_sub.olddepth = CvDEPTH(cv);
2318 if (CvDEPTH(cv) < 2)
2319 (void)SvREFCNT_inc(cv);
2320 else { /* save temporaries on recursion? */
2321 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2322 sub_crush_depth(cv);
2323 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2324 AV *newpad = newAV();
2325 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2326 I32 ix = AvFILLp((AV*)svp[1]);
2327 I32 names_fill = AvFILLp((AV*)svp[0]);
2328 svp = AvARRAY(svp[0]);
2329 for ( ;ix > 0; ix--) {
2330 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2331 char *name = SvPVX(svp[ix]);
2332 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2335 /* outer lexical or anon code */
2336 av_store(newpad, ix,
2337 SvREFCNT_inc(oldpad[ix]) );
2339 else { /* our own lexical */
2341 av_store(newpad, ix, sv = (SV*)newAV());
2342 else if (*name == '%')
2343 av_store(newpad, ix, sv = (SV*)newHV());
2345 av_store(newpad, ix, sv = NEWSV(0,0));
2349 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2350 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2353 av_store(newpad, ix, sv = NEWSV(0,0));
2357 if (cx->blk_sub.hasargs) {
2360 av_store(newpad, 0, (SV*)av);
2361 AvFLAGS(av) = AVf_REIFY;
2363 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2364 AvFILLp(padlist) = CvDEPTH(cv);
2365 svp = AvARRAY(padlist);
2369 if (!cx->blk_sub.hasargs) {
2370 AV* av = (AV*)PL_curpad[0];
2372 items = AvFILLp(av) + 1;
2374 /* Mark is at the end of the stack. */
2376 Copy(AvARRAY(av), SP + 1, items, SV*);
2381 #endif /* USE_THREADS */
2382 SAVEVPTR(PL_curpad);
2383 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2385 if (cx->blk_sub.hasargs)
2386 #endif /* USE_THREADS */
2388 AV* av = (AV*)PL_curpad[0];
2392 cx->blk_sub.savearray = GvAV(PL_defgv);
2393 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2394 #endif /* USE_THREADS */
2395 cx->blk_sub.oldcurpad = PL_curpad;
2396 cx->blk_sub.argarray = av;
2399 if (items >= AvMAX(av) + 1) {
2401 if (AvARRAY(av) != ary) {
2402 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2403 SvPVX(av) = (char*)ary;
2405 if (items >= AvMAX(av) + 1) {
2406 AvMAX(av) = items - 1;
2407 Renew(ary,items+1,SV*);
2409 SvPVX(av) = (char*)ary;
2412 Copy(mark,AvARRAY(av),items,SV*);
2413 AvFILLp(av) = items - 1;
2414 assert(!AvREAL(av));
2421 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2423 * We do not care about using sv to call CV;
2424 * it's for informational purposes only.
2426 SV *sv = GvSV(PL_DBsub);
2429 if (PERLDB_SUB_NN) {
2430 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2433 gv_efullname3(sv, CvGV(cv), Nullch);
2436 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2437 PUSHMARK( PL_stack_sp );
2438 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2442 RETURNOP(CvSTART(cv));
2446 label = SvPV(sv,n_a);
2447 if (!(do_dump || *label))
2448 DIE(aTHX_ must_have_label);
2451 else if (PL_op->op_flags & OPf_SPECIAL) {
2453 DIE(aTHX_ must_have_label);
2456 label = cPVOP->op_pv;
2458 if (label && *label) {
2460 bool leaving_eval = FALSE;
2461 PERL_CONTEXT *last_eval_cx = 0;
2465 PL_lastgotoprobe = 0;
2467 for (ix = cxstack_ix; ix >= 0; ix--) {
2469 switch (CxTYPE(cx)) {
2471 leaving_eval = TRUE;
2472 if (CxREALEVAL(cx)) {
2473 gotoprobe = (last_eval_cx ?
2474 last_eval_cx->blk_eval.old_eval_root :
2479 /* else fall through */
2481 gotoprobe = cx->blk_oldcop->op_sibling;
2487 gotoprobe = cx->blk_oldcop->op_sibling;
2489 gotoprobe = PL_main_root;
2492 if (CvDEPTH(cx->blk_sub.cv)) {
2493 gotoprobe = CvROOT(cx->blk_sub.cv);
2499 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2502 DIE(aTHX_ "panic: goto");
2503 gotoprobe = PL_main_root;
2507 retop = dofindlabel(gotoprobe, label,
2508 enterops, enterops + GOTO_DEPTH);
2512 PL_lastgotoprobe = gotoprobe;
2515 DIE(aTHX_ "Can't find label %s", label);
2517 /* if we're leaving an eval, check before we pop any frames
2518 that we're not going to punt, otherwise the error
2521 if (leaving_eval && *enterops && enterops[1]) {
2523 for (i = 1; enterops[i]; i++)
2524 if (enterops[i]->op_type == OP_ENTERITER)
2525 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2528 /* pop unwanted frames */
2530 if (ix < cxstack_ix) {
2537 oldsave = PL_scopestack[PL_scopestack_ix];
2538 LEAVE_SCOPE(oldsave);
2541 /* push wanted frames */
2543 if (*enterops && enterops[1]) {
2545 for (ix = 1; enterops[ix]; ix++) {
2546 PL_op = enterops[ix];
2547 /* Eventually we may want to stack the needed arguments
2548 * for each op. For now, we punt on the hard ones. */
2549 if (PL_op->op_type == OP_ENTERITER)
2550 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2551 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2559 if (!retop) retop = PL_main_start;
2561 PL_restartop = retop;
2562 PL_do_undump = TRUE;
2566 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2567 PL_do_undump = FALSE;
2583 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2587 PL_exit_flags |= PERL_EXIT_EXPECTED;
2589 PUSHs(&PL_sv_undef);
2597 NV value = SvNVx(GvSV(cCOP->cop_gv));
2598 register I32 match = I_32(value);
2601 if (((NV)match) > value)
2602 --match; /* was fractional--truncate other way */
2604 match -= cCOP->uop.scop.scop_offset;
2607 else if (match > cCOP->uop.scop.scop_max)
2608 match = cCOP->uop.scop.scop_max;
2609 PL_op = cCOP->uop.scop.scop_next[match];
2619 PL_op = PL_op->op_next; /* can't assume anything */
2622 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2623 match -= cCOP->uop.scop.scop_offset;
2626 else if (match > cCOP->uop.scop.scop_max)
2627 match = cCOP->uop.scop.scop_max;
2628 PL_op = cCOP->uop.scop.scop_next[match];
2637 S_save_lines(pTHX_ AV *array, SV *sv)
2639 register char *s = SvPVX(sv);
2640 register char *send = SvPVX(sv) + SvCUR(sv);
2642 register I32 line = 1;
2644 while (s && s < send) {
2645 SV *tmpstr = NEWSV(85,0);
2647 sv_upgrade(tmpstr, SVt_PVMG);
2648 t = strchr(s, '\n');
2654 sv_setpvn(tmpstr, s, t - s);
2655 av_store(array, line++, tmpstr);
2660 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2662 S_docatch_body(pTHX_ va_list args)
2664 return docatch_body();
2669 S_docatch_body(pTHX)
2676 S_docatch(pTHX_ OP *o)
2680 volatile PERL_SI *cursi = PL_curstackinfo;
2684 assert(CATCH_GET == TRUE);
2687 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2689 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2695 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2701 if (PL_restartop && cursi == PL_curstackinfo) {
2702 PL_op = PL_restartop;
2719 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2720 /* sv Text to convert to OP tree. */
2721 /* startop op_free() this to undo. */
2722 /* code Short string id of the caller. */
2724 dSP; /* Make POPBLOCK work. */
2727 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2731 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2732 char *tmpbuf = tbuf;
2738 /* switch to eval mode */
2740 if (PL_curcop == &PL_compiling) {
2741 SAVECOPSTASH_FREE(&PL_compiling);
2742 CopSTASH_set(&PL_compiling, PL_curstash);
2744 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2745 SV *sv = sv_newmortal();
2746 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2747 code, (unsigned long)++PL_evalseq,
2748 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2752 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2753 SAVECOPFILE_FREE(&PL_compiling);
2754 CopFILE_set(&PL_compiling, tmpbuf+2);
2755 SAVECOPLINE(&PL_compiling);
2756 CopLINE_set(&PL_compiling, 1);
2757 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2758 deleting the eval's FILEGV from the stash before gv_check() runs
2759 (i.e. before run-time proper). To work around the coredump that
2760 ensues, we always turn GvMULTI_on for any globals that were
2761 introduced within evals. See force_ident(). GSAR 96-10-12 */
2762 safestr = savepv(tmpbuf);
2763 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2765 #ifdef OP_IN_REGISTER
2770 PL_hints &= HINT_UTF8;
2773 PL_op->op_type = OP_ENTEREVAL;
2774 PL_op->op_flags = 0; /* Avoid uninit warning. */
2775 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2776 PUSHEVAL(cx, 0, Nullgv);
2777 rop = doeval(G_SCALAR, startop);
2778 POPBLOCK(cx,PL_curpm);
2781 (*startop)->op_type = OP_NULL;
2782 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2784 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2786 if (PL_curcop == &PL_compiling)
2787 PL_compiling.op_private = PL_hints;
2788 #ifdef OP_IN_REGISTER
2794 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2796 S_doeval(pTHX_ int gimme, OP** startop)
2804 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2805 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2810 /* set up a scratch pad */
2813 SAVEVPTR(PL_curpad);
2814 SAVESPTR(PL_comppad);
2815 SAVESPTR(PL_comppad_name);
2816 SAVEI32(PL_comppad_name_fill);
2817 SAVEI32(PL_min_intro_pending);
2818 SAVEI32(PL_max_intro_pending);
2821 for (i = cxstack_ix - 1; i >= 0; i--) {
2822 PERL_CONTEXT *cx = &cxstack[i];
2823 if (CxTYPE(cx) == CXt_EVAL)
2825 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2826 caller = cx->blk_sub.cv;
2831 SAVESPTR(PL_compcv);
2832 PL_compcv = (CV*)NEWSV(1104,0);
2833 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2834 CvEVAL_on(PL_compcv);
2836 CvOWNER(PL_compcv) = 0;
2837 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2838 MUTEX_INIT(CvMUTEXP(PL_compcv));
2839 #endif /* USE_THREADS */
2841 PL_comppad = newAV();
2842 av_push(PL_comppad, Nullsv);
2843 PL_curpad = AvARRAY(PL_comppad);
2844 PL_comppad_name = newAV();
2845 PL_comppad_name_fill = 0;
2846 PL_min_intro_pending = 0;
2849 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2850 PL_curpad[0] = (SV*)newAV();
2851 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2852 #endif /* USE_THREADS */
2854 comppadlist = newAV();
2855 AvREAL_off(comppadlist);
2856 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2857 av_store(comppadlist, 1, (SV*)PL_comppad);
2858 CvPADLIST(PL_compcv) = comppadlist;
2861 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2863 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2866 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2868 /* make sure we compile in the right package */
2870 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2871 SAVESPTR(PL_curstash);
2872 PL_curstash = CopSTASH(PL_curcop);
2874 SAVESPTR(PL_beginav);
2875 PL_beginav = newAV();
2876 SAVEFREESV(PL_beginav);
2877 SAVEI32(PL_error_count);
2879 /* try to compile it */
2881 PL_eval_root = Nullop;
2883 PL_curcop = &PL_compiling;
2884 PL_curcop->cop_arybase = 0;
2885 SvREFCNT_dec(PL_rs);
2886 PL_rs = newSVpvn("\n", 1);
2887 if (saveop && saveop->op_flags & OPf_SPECIAL)
2888 PL_in_eval |= EVAL_KEEPERR;
2891 if (yyparse() || PL_error_count || !PL_eval_root) {
2895 I32 optype = 0; /* Might be reset by POPEVAL. */
2900 op_free(PL_eval_root);
2901 PL_eval_root = Nullop;
2903 SP = PL_stack_base + POPMARK; /* pop original mark */
2905 POPBLOCK(cx,PL_curpm);
2911 if (optype == OP_REQUIRE) {
2912 char* msg = SvPVx(ERRSV, n_a);
2913 DIE(aTHX_ "%sCompilation failed in require",
2914 *msg ? msg : "Unknown error\n");
2917 char* msg = SvPVx(ERRSV, n_a);
2919 POPBLOCK(cx,PL_curpm);
2921 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2922 (*msg ? msg : "Unknown error\n"));
2924 SvREFCNT_dec(PL_rs);
2925 PL_rs = SvREFCNT_inc(PL_nrs);
2927 MUTEX_LOCK(&PL_eval_mutex);
2929 COND_SIGNAL(&PL_eval_cond);
2930 MUTEX_UNLOCK(&PL_eval_mutex);
2931 #endif /* USE_THREADS */
2934 SvREFCNT_dec(PL_rs);
2935 PL_rs = SvREFCNT_inc(PL_nrs);
2936 CopLINE_set(&PL_compiling, 0);
2938 *startop = PL_eval_root;
2939 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2940 CvOUTSIDE(PL_compcv) = Nullcv;
2942 SAVEFREEOP(PL_eval_root);
2944 scalarvoid(PL_eval_root);
2945 else if (gimme & G_ARRAY)
2948 scalar(PL_eval_root);
2950 DEBUG_x(dump_eval());
2952 /* Register with debugger: */
2953 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2954 CV *cv = get_cv("DB::postponed", FALSE);
2958 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2960 call_sv((SV*)cv, G_DISCARD);
2964 /* compiled okay, so do it */
2966 CvDEPTH(PL_compcv) = 1;
2967 SP = PL_stack_base + POPMARK; /* pop original mark */
2968 PL_op = saveop; /* The caller may need it. */
2969 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2971 MUTEX_LOCK(&PL_eval_mutex);
2973 COND_SIGNAL(&PL_eval_cond);
2974 MUTEX_UNLOCK(&PL_eval_mutex);
2975 #endif /* USE_THREADS */
2977 RETURNOP(PL_eval_start);
2981 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2983 STRLEN namelen = strlen(name);
2986 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2987 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2988 char *pmc = SvPV_nolen(pmcsv);
2991 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2992 fp = PerlIO_open(name, mode);
2995 if (PerlLIO_stat(name, &pmstat) < 0 ||
2996 pmstat.st_mtime < pmcstat.st_mtime)
2998 fp = PerlIO_open(pmc, mode);
3001 fp = PerlIO_open(name, mode);
3004 SvREFCNT_dec(pmcsv);
3007 fp = PerlIO_open(name, mode);
3015 register PERL_CONTEXT *cx;
3019 char *tryname = Nullch;
3020 SV *namesv = Nullsv;
3022 I32 gimme = GIMME_V;
3023 PerlIO *tryrsfp = 0;
3025 int filter_has_file = 0;
3026 GV *filter_child_proc = 0;
3027 SV *filter_state = 0;
3032 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3033 UV rev = 0, ver = 0, sver = 0;
3035 U8 *s = (U8*)SvPVX(sv);
3036 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3038 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3041 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3044 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3047 if (PERL_REVISION < rev
3048 || (PERL_REVISION == rev
3049 && (PERL_VERSION < ver
3050 || (PERL_VERSION == ver
3051 && PERL_SUBVERSION < sver))))
3053 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3054 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3055 PERL_VERSION, PERL_SUBVERSION);
3059 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3060 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3061 + ((NV)PERL_SUBVERSION/(NV)1000000)
3062 + 0.00000099 < SvNV(sv))
3066 NV nver = (nrev - rev) * 1000;
3067 UV ver = (UV)(nver + 0.0009);
3068 NV nsver = (nver - ver) * 1000;
3069 UV sver = (UV)(nsver + 0.0009);
3071 /* help out with the "use 5.6" confusion */
3072 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3073 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3074 "this is only v%d.%d.%d, stopped"
3075 " (did you mean v%"UVuf".%"UVuf".0?)",
3076 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3077 PERL_SUBVERSION, rev, ver/100);
3080 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3081 "this is only v%d.%d.%d, stopped",
3082 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3089 name = SvPV(sv, len);
3090 if (!(name && len > 0 && *name))
3091 DIE(aTHX_ "Null filename used");
3092 TAINT_PROPER("require");
3093 if (PL_op->op_type == OP_REQUIRE &&
3094 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3095 *svp != &PL_sv_undef)
3098 /* prepare to compile file */
3100 #ifdef MACOS_TRADITIONAL
3101 if (PERL_FILE_IS_ABSOLUTE(name)
3102 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3105 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3106 /* We consider paths of the form :a:b ambiguous and interpret them first
3107 as global then as local
3109 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3115 if (PERL_FILE_IS_ABSOLUTE(name)
3116 || (*name == '.' && (name[1] == '/' ||
3117 (name[1] == '.' && name[2] == '/'))))
3120 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3124 AV *ar = GvAVn(PL_incgv);
3128 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3131 namesv = NEWSV(806, 0);
3132 for (i = 0; i <= AvFILL(ar); i++) {
3133 SV *dirsv = *av_fetch(ar, i, TRUE);
3139 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3140 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3143 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3144 PTR2UV(SvANY(loader)), name);
3145 tryname = SvPVX(namesv);
3156 if (sv_isobject(loader))
3157 count = call_method("INC", G_ARRAY);
3159 count = call_sv(loader, G_ARRAY);
3169 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3173 if (SvTYPE(arg) == SVt_PVGV) {
3174 IO *io = GvIO((GV *)arg);
3179 tryrsfp = IoIFP(io);
3180 if (IoTYPE(io) == IoTYPE_PIPE) {
3181 /* reading from a child process doesn't
3182 nest -- when returning from reading
3183 the inner module, the outer one is
3184 unreadable (closed?) I've tried to
3185 save the gv to manage the lifespan of
3186 the pipe, but this didn't help. XXX */
3187 filter_child_proc = (GV *)arg;
3188 (void)SvREFCNT_inc(filter_child_proc);
3191 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3192 PerlIO_close(IoOFP(io));
3204 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3206 (void)SvREFCNT_inc(filter_sub);
3209 filter_state = SP[i];
3210 (void)SvREFCNT_inc(filter_state);
3214 tryrsfp = PerlIO_open("/dev/null",
3228 filter_has_file = 0;
3229 if (filter_child_proc) {
3230 SvREFCNT_dec(filter_child_proc);
3231 filter_child_proc = 0;
3234 SvREFCNT_dec(filter_state);
3238 SvREFCNT_dec(filter_sub);
3243 char *dir = SvPVx(dirsv, n_a);
3244 #ifdef MACOS_TRADITIONAL
3246 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3250 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3252 sv_setpv(namesv, unixdir);
3253 sv_catpv(namesv, unixname);
3255 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3258 TAINT_PROPER("require");
3259 tryname = SvPVX(namesv);
3260 #ifdef MACOS_TRADITIONAL
3262 /* Convert slashes in the name part, but not the directory part, to colons */
3264 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3268 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3270 if (tryname[0] == '.' && tryname[1] == '/')
3278 SAVECOPFILE_FREE(&PL_compiling);
3279 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3280 SvREFCNT_dec(namesv);
3282 if (PL_op->op_type == OP_REQUIRE) {
3283 char *msgstr = name;
3284 if (namesv) { /* did we lookup @INC? */
3285 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3286 SV *dirmsgsv = NEWSV(0, 0);
3287 AV *ar = GvAVn(PL_incgv);
3289 sv_catpvn(msg, " in @INC", 8);
3290 if (instr(SvPVX(msg), ".h "))
3291 sv_catpv(msg, " (change .h to .ph maybe?)");
3292 if (instr(SvPVX(msg), ".ph "))
3293 sv_catpv(msg, " (did you run h2ph?)");
3294 sv_catpv(msg, " (@INC contains:");
3295 for (i = 0; i <= AvFILL(ar); i++) {
3296 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3297 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3298 sv_catsv(msg, dirmsgsv);
3300 sv_catpvn(msg, ")", 1);
3301 SvREFCNT_dec(dirmsgsv);
3302 msgstr = SvPV_nolen(msg);
3304 DIE(aTHX_ "Can't locate %s", msgstr);
3310 SETERRNO(0, SS$_NORMAL);
3312 /* Assume success here to prevent recursive requirement. */
3313 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3314 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3318 lex_start(sv_2mortal(newSVpvn("",0)));
3319 SAVEGENERICSV(PL_rsfp_filters);
3320 PL_rsfp_filters = Nullav;
3325 SAVESPTR(PL_compiling.cop_warnings);
3326 if (PL_dowarn & G_WARN_ALL_ON)
3327 PL_compiling.cop_warnings = pWARN_ALL ;
3328 else if (PL_dowarn & G_WARN_ALL_OFF)
3329 PL_compiling.cop_warnings = pWARN_NONE ;
3331 PL_compiling.cop_warnings = pWARN_STD ;
3332 SAVESPTR(PL_compiling.cop_io);
3333 PL_compiling.cop_io = Nullsv;
3335 if (filter_sub || filter_child_proc) {
3336 SV *datasv = filter_add(run_user_filter, Nullsv);
3337 IoLINES(datasv) = filter_has_file;
3338 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3339 IoTOP_GV(datasv) = (GV *)filter_state;
3340 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3343 /* switch to eval mode */
3344 push_return(PL_op->op_next);
3345 PUSHBLOCK(cx, CXt_EVAL, SP);
3346 PUSHEVAL(cx, name, Nullgv);
3348 SAVECOPLINE(&PL_compiling);
3349 CopLINE_set(&PL_compiling, 0);
3353 MUTEX_LOCK(&PL_eval_mutex);
3354 if (PL_eval_owner && PL_eval_owner != thr)
3355 while (PL_eval_owner)
3356 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3357 PL_eval_owner = thr;
3358 MUTEX_UNLOCK(&PL_eval_mutex);
3359 #endif /* USE_THREADS */
3360 return DOCATCH(doeval(gimme, NULL));
3365 return pp_require();
3371 register PERL_CONTEXT *cx;
3373 I32 gimme = GIMME_V, was = PL_sub_generation;
3374 char tbuf[TYPE_DIGITS(long) + 12];
3375 char *tmpbuf = tbuf;
3380 if (!SvPV(sv,len) || !len)
3382 TAINT_PROPER("eval");
3388 /* switch to eval mode */
3390 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3391 SV *sv = sv_newmortal();
3392 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3393 (unsigned long)++PL_evalseq,
3394 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3398 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3399 SAVECOPFILE_FREE(&PL_compiling);
3400 CopFILE_set(&PL_compiling, tmpbuf+2);
3401 SAVECOPLINE(&PL_compiling);
3402 CopLINE_set(&PL_compiling, 1);
3403 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3404 deleting the eval's FILEGV from the stash before gv_check() runs
3405 (i.e. before run-time proper). To work around the coredump that
3406 ensues, we always turn GvMULTI_on for any globals that were
3407 introduced within evals. See force_ident(). GSAR 96-10-12 */
3408 safestr = savepv(tmpbuf);
3409 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3411 PL_hints = PL_op->op_targ;
3412 SAVESPTR(PL_compiling.cop_warnings);
3413 if (specialWARN(PL_curcop->cop_warnings))
3414 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3416 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3417 SAVEFREESV(PL_compiling.cop_warnings);
3419 SAVESPTR(PL_compiling.cop_io);
3420 if (specialCopIO(PL_curcop->cop_io))
3421 PL_compiling.cop_io = PL_curcop->cop_io;
3423 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3424 SAVEFREESV(PL_compiling.cop_io);
3427 push_return(PL_op->op_next);
3428 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3429 PUSHEVAL(cx, 0, Nullgv);
3431 /* prepare to compile string */
3433 if (PERLDB_LINE && PL_curstash != PL_debstash)
3434 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3437 MUTEX_LOCK(&PL_eval_mutex);
3438 if (PL_eval_owner && PL_eval_owner != thr)
3439 while (PL_eval_owner)
3440 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3441 PL_eval_owner = thr;
3442 MUTEX_UNLOCK(&PL_eval_mutex);
3443 #endif /* USE_THREADS */
3444 ret = doeval(gimme, NULL);
3445 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3446 && ret != PL_op->op_next) { /* Successive compilation. */
3447 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3449 return DOCATCH(ret);
3459 register PERL_CONTEXT *cx;
3461 U8 save_flags = PL_op -> op_flags;
3466 retop = pop_return();
3469 if (gimme == G_VOID)
3471 else if (gimme == G_SCALAR) {
3474 if (SvFLAGS(TOPs) & SVs_TEMP)
3477 *MARK = sv_mortalcopy(TOPs);
3481 *MARK = &PL_sv_undef;
3486 /* in case LEAVE wipes old return values */
3487 for (mark = newsp + 1; mark <= SP; mark++) {
3488 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3489 *mark = sv_mortalcopy(*mark);
3490 TAINT_NOT; /* Each item is independent */
3494 PL_curpm = newpm; /* Don't pop $1 et al till now */
3497 assert(CvDEPTH(PL_compcv) == 1);
3499 CvDEPTH(PL_compcv) = 0;
3502 if (optype == OP_REQUIRE &&
3503 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3505 /* Unassume the success we assumed earlier. */
3506 SV *nsv = cx->blk_eval.old_namesv;
3507 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3508 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3509 /* die_where() did LEAVE, or we won't be here */
3513 if (!(save_flags & OPf_SPECIAL))
3523 register PERL_CONTEXT *cx;
3524 I32 gimme = GIMME_V;
3529 push_return(cLOGOP->op_other->op_next);
3530 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3533 PL_in_eval = EVAL_INEVAL;
3536 return DOCATCH(PL_op->op_next);
3546 register PERL_CONTEXT *cx;
3554 if (gimme == G_VOID)
3556 else if (gimme == G_SCALAR) {
3559 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3562 *MARK = sv_mortalcopy(TOPs);
3566 *MARK = &PL_sv_undef;
3571 /* in case LEAVE wipes old return values */
3572 for (mark = newsp + 1; mark <= SP; mark++) {
3573 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3574 *mark = sv_mortalcopy(*mark);
3575 TAINT_NOT; /* Each item is independent */
3579 PL_curpm = newpm; /* Don't pop $1 et al till now */
3587 S_doparseform(pTHX_ SV *sv)
3590 register char *s = SvPV_force(sv, len);
3591 register char *send = s + len;
3592 register char *base = Nullch;
3593 register I32 skipspaces = 0;
3594 bool noblank = FALSE;
3595 bool repeat = FALSE;
3596 bool postspace = FALSE;
3604 Perl_croak(aTHX_ "Null picture in formline");
3606 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3611 *fpc++ = FF_LINEMARK;
3612 noblank = repeat = FALSE;
3630 case ' ': case '\t':
3641 *fpc++ = FF_LITERAL;
3649 *fpc++ = skipspaces;
3653 *fpc++ = FF_NEWLINE;
3657 arg = fpc - linepc + 1;
3664 *fpc++ = FF_LINEMARK;
3665 noblank = repeat = FALSE;
3674 ischop = s[-1] == '^';
3680 arg = (s - base) - 1;
3682 *fpc++ = FF_LITERAL;
3691 *fpc++ = FF_LINEGLOB;
3693 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3694 arg = ischop ? 512 : 0;
3704 arg |= 256 + (s - f);
3706 *fpc++ = s - base; /* fieldsize for FETCH */
3707 *fpc++ = FF_DECIMAL;
3710 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3711 arg = ischop ? 512 : 0;
3713 s++; /* skip the '0' first */
3722 arg |= 256 + (s - f);
3724 *fpc++ = s - base; /* fieldsize for FETCH */
3725 *fpc++ = FF_0DECIMAL;
3730 bool ismore = FALSE;
3733 while (*++s == '>') ;
3734 prespace = FF_SPACE;
3736 else if (*s == '|') {
3737 while (*++s == '|') ;
3738 prespace = FF_HALFSPACE;
3743 while (*++s == '<') ;
3746 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3750 *fpc++ = s - base; /* fieldsize for FETCH */
3752 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3770 { /* need to jump to the next word */
3772 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3773 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3774 s = SvPVX(sv) + SvCUR(sv) + z;
3776 Copy(fops, s, arg, U16);
3778 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3783 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3785 * The original code was written in conjunction with BSD Computer Software
3786 * Research Group at University of California, Berkeley.
3788 * See also: "Optimistic Merge Sort" (SODA '92)
3790 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3792 * The code can be distributed under the same terms as Perl itself.
3797 #include <sys/types.h>
3802 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3803 #define Safefree(VAR) free(VAR)
3804 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3805 #endif /* TESTHARNESS */
3807 typedef char * aptr; /* pointer for arithmetic on sizes */
3808 typedef SV * gptr; /* pointers in our lists */
3810 /* Binary merge internal sort, with a few special mods
3811 ** for the special perl environment it now finds itself in.
3813 ** Things that were once options have been hotwired
3814 ** to values suitable for this use. In particular, we'll always
3815 ** initialize looking for natural runs, we'll always produce stable
3816 ** output, and we'll always do Peter McIlroy's binary merge.
3819 /* Pointer types for arithmetic and storage and convenience casts */
3821 #define APTR(P) ((aptr)(P))
3822 #define GPTP(P) ((gptr *)(P))
3823 #define GPPP(P) ((gptr **)(P))
3826 /* byte offset from pointer P to (larger) pointer Q */
3827 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3829 #define PSIZE sizeof(gptr)
3831 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3834 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3835 #define PNBYTE(N) ((N) << (PSHIFT))
3836 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3838 /* Leave optimization to compiler */
3839 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3840 #define PNBYTE(N) ((N) * (PSIZE))
3841 #define PINDEX(P, N) (GPTP(P) + (N))
3844 /* Pointer into other corresponding to pointer into this */
3845 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3847 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3850 /* Runs are identified by a pointer in the auxilliary list.
3851 ** The pointer is at the start of the list,
3852 ** and it points to the start of the next list.
3853 ** NEXT is used as an lvalue, too.
3856 #define NEXT(P) (*GPPP(P))
3859 /* PTHRESH is the minimum number of pairs with the same sense to justify
3860 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3861 ** not just elements, so PTHRESH == 8 means a run of 16.
3866 /* RTHRESH is the number of elements in a run that must compare low
3867 ** to the low element from the opposing run before we justify
3868 ** doing a binary rampup instead of single stepping.
3869 ** In random input, N in a row low should only happen with
3870 ** probability 2^(1-N), so we can risk that we are dealing
3871 ** with orderly input without paying much when we aren't.
3878 ** Overview of algorithm and variables.
3879 ** The array of elements at list1 will be organized into runs of length 2,
3880 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3881 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3883 ** Unless otherwise specified, pair pointers address the first of two elements.
3885 ** b and b+1 are a pair that compare with sense ``sense''.
3886 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3888 ** p2 parallels b in the list2 array, where runs are defined by
3891 ** t represents the ``top'' of the adjacent pairs that might extend
3892 ** the run beginning at b. Usually, t addresses a pair
3893 ** that compares with opposite sense from (b,b+1).
3894 ** However, it may also address a singleton element at the end of list1,
3895 ** or it may be equal to ``last'', the first element beyond list1.
3897 ** r addresses the Nth pair following b. If this would be beyond t,
3898 ** we back it off to t. Only when r is less than t do we consider the
3899 ** run long enough to consider checking.
3901 ** q addresses a pair such that the pairs at b through q already form a run.
3902 ** Often, q will equal b, indicating we only are sure of the pair itself.
3903 ** However, a search on the previous cycle may have revealed a longer run,
3904 ** so q may be greater than b.
3906 ** p is used to work back from a candidate r, trying to reach q,
3907 ** which would mean b through r would be a run. If we discover such a run,
3908 ** we start q at r and try to push it further towards t.
3909 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3910 ** In any event, after the check (if any), we have two main cases.
3912 ** 1) Short run. b <= q < p <= r <= t.
3913 ** b through q is a run (perhaps trivial)
3914 ** q through p are uninteresting pairs
3915 ** p through r is a run
3917 ** 2) Long run. b < r <= q < t.
3918 ** b through q is a run (of length >= 2 * PTHRESH)
3920 ** Note that degenerate cases are not only possible, but likely.
3921 ** For example, if the pair following b compares with opposite sense,
3922 ** then b == q < p == r == t.
3927 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3930 register gptr *b, *p, *q, *t, *p2;
3931 register gptr c, *last, *r;
3935 last = PINDEX(b, nmemb);
3936 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3937 for (p2 = list2; b < last; ) {
3938 /* We just started, or just reversed sense.
3939 ** Set t at end of pairs with the prevailing sense.
3941 for (p = b+2, t = p; ++p < last; t = ++p) {
3942 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3945 /* Having laid out the playing field, look for long runs */
3947 p = r = b + (2 * PTHRESH);
3948 if (r >= t) p = r = t; /* too short to care about */
3950 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3953 /* b through r is a (long) run.
3954 ** Extend it as far as possible.
3957 while (((p += 2) < t) &&
3958 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3959 r = p = q + 2; /* no simple pairs, no after-run */
3962 if (q > b) { /* run of greater than 2 at b */
3965 /* pick up singleton, if possible */
3967 ((t + 1) == last) &&
3968 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3969 savep = r = p = q = last;
3970 p2 = NEXT(p2) = p2 + (p - b);
3971 if (sense) while (b < --p) {
3978 while (q < p) { /* simple pairs */
3979 p2 = NEXT(p2) = p2 + 2;
3986 if (((b = p) == t) && ((t+1) == last)) {
3998 /* Overview of bmerge variables:
4000 ** list1 and list2 address the main and auxiliary arrays.
4001 ** They swap identities after each merge pass.
4002 ** Base points to the original list1, so we can tell if
4003 ** the pointers ended up where they belonged (or must be copied).
4005 ** When we are merging two lists, f1 and f2 are the next elements
4006 ** on the respective lists. l1 and l2 mark the end of the lists.
4007 ** tp2 is the current location in the merged list.
4009 ** p1 records where f1 started.
4010 ** After the merge, a new descriptor is built there.
4012 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4013 ** It is used to identify and delimit the runs.
4015 ** In the heat of determining where q, the greater of the f1/f2 elements,
4016 ** belongs in the other list, b, t and p, represent bottom, top and probe
4017 ** locations, respectively, in the other list.
4018 ** They make convenient temporary pointers in other places.
4022 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4026 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4027 gptr *aux, *list2, *p2, *last;
4031 if (nmemb <= 1) return; /* sorted trivially */
4032 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4034 dynprep(aTHX_ list1, list2, nmemb, cmp);
4035 last = PINDEX(list2, nmemb);
4036 while (NEXT(list2) != last) {
4037 /* More than one run remains. Do some merging to reduce runs. */
4039 for (tp2 = p2 = list2; p2 != last;) {
4040 /* The new first run begins where the old second list ended.
4041 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4045 f2 = l1 = POTHER(t, list2, list1);
4046 if (t != last) t = NEXT(t);
4047 l2 = POTHER(t, list2, list1);
4049 while (f1 < l1 && f2 < l2) {
4050 /* If head 1 is larger than head 2, find ALL the elements
4051 ** in list 2 strictly less than head1, write them all,
4052 ** then head 1. Then compare the new heads, and repeat,
4053 ** until one or both lists are exhausted.
4055 ** In all comparisons (after establishing
4056 ** which head to merge) the item to merge
4057 ** (at pointer q) is the first operand of
4058 ** the comparison. When we want to know
4059 ** if ``q is strictly less than the other'',
4061 ** cmp(q, other) < 0
4062 ** because stability demands that we treat equality
4063 ** as high when q comes from l2, and as low when
4064 ** q was from l1. So we ask the question by doing
4065 ** cmp(q, other) <= sense
4066 ** and make sense == 0 when equality should look low,
4067 ** and -1 when equality should look high.
4071 if (cmp(aTHX_ *f1, *f2) <= 0) {
4072 q = f2; b = f1; t = l1;
4075 q = f1; b = f2; t = l2;
4082 ** Leave t at something strictly
4083 ** greater than q (or at the end of the list),
4084 ** and b at something strictly less than q.
4086 for (i = 1, run = 0 ;;) {
4087 if ((p = PINDEX(b, i)) >= t) {
4089 if (((p = PINDEX(t, -1)) > b) &&
4090 (cmp(aTHX_ *q, *p) <= sense))
4094 } else if (cmp(aTHX_ *q, *p) <= sense) {
4098 if (++run >= RTHRESH) i += i;
4102 /* q is known to follow b and must be inserted before t.
4103 ** Increment b, so the range of possibilities is [b,t).
4104 ** Round binary split down, to favor early appearance.
4105 ** Adjust b and t until q belongs just before t.
4110 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4111 if (cmp(aTHX_ *q, *p) <= sense) {
4117 /* Copy all the strictly low elements */
4120 FROMTOUPTO(f2, tp2, t);
4123 FROMTOUPTO(f1, tp2, t);
4129 /* Run out remaining list */
4131 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4132 } else FROMTOUPTO(f1, tp2, l1);
4133 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4138 last = PINDEX(list2, nmemb);
4140 if (base == list2) {
4141 last = PINDEX(list1, nmemb);
4142 FROMTOUPTO(list1, list2, last);
4157 sortcv(pTHXo_ SV *a, SV *b)
4159 I32 oldsaveix = PL_savestack_ix;
4160 I32 oldscopeix = PL_scopestack_ix;
4162 GvSV(PL_firstgv) = a;
4163 GvSV(PL_secondgv) = b;
4164 PL_stack_sp = PL_stack_base;
4167 if (PL_stack_sp != PL_stack_base + 1)
4168 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4169 if (!SvNIOKp(*PL_stack_sp))
4170 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4171 result = SvIV(*PL_stack_sp);
4172 while (PL_scopestack_ix > oldscopeix) {
4175 leave_scope(oldsaveix);
4180 sortcv_stacked(pTHXo_ SV *a, SV *b)
4182 I32 oldsaveix = PL_savestack_ix;
4183 I32 oldscopeix = PL_scopestack_ix;
4188 av = (AV*)PL_curpad[0];
4190 av = GvAV(PL_defgv);
4193 if (AvMAX(av) < 1) {
4194 SV** ary = AvALLOC(av);
4195 if (AvARRAY(av) != ary) {
4196 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4197 SvPVX(av) = (char*)ary;
4199 if (AvMAX(av) < 1) {
4202 SvPVX(av) = (char*)ary;
4209 PL_stack_sp = PL_stack_base;
4212 if (PL_stack_sp != PL_stack_base + 1)
4213 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4214 if (!SvNIOKp(*PL_stack_sp))
4215 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4216 result = SvIV(*PL_stack_sp);
4217 while (PL_scopestack_ix > oldscopeix) {
4220 leave_scope(oldsaveix);
4225 sortcv_xsub(pTHXo_ SV *a, SV *b)
4228 I32 oldsaveix = PL_savestack_ix;
4229 I32 oldscopeix = PL_scopestack_ix;
4231 CV *cv=(CV*)PL_sortcop;
4239 (void)(*CvXSUB(cv))(aTHXo_ cv);
4240 if (PL_stack_sp != PL_stack_base + 1)
4241 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4242 if (!SvNIOKp(*PL_stack_sp))
4243 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4244 result = SvIV(*PL_stack_sp);
4245 while (PL_scopestack_ix > oldscopeix) {
4248 leave_scope(oldsaveix);
4254 sv_ncmp(pTHXo_ SV *a, SV *b)
4258 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4262 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4266 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4268 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4270 if (PL_amagic_generation) { \
4271 if (SvAMAGIC(left)||SvAMAGIC(right))\
4272 *svp = amagic_call(left, \
4280 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4283 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4288 I32 i = SvIVX(tmpsv);
4298 return sv_ncmp(aTHXo_ a, b);
4302 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4305 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4310 I32 i = SvIVX(tmpsv);
4320 return sv_i_ncmp(aTHXo_ a, b);
4324 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4327 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4332 I32 i = SvIVX(tmpsv);
4342 return sv_cmp(str1, str2);
4346 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4349 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4354 I32 i = SvIVX(tmpsv);
4364 return sv_cmp_locale(str1, str2);
4368 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4370 SV *datasv = FILTER_DATA(idx);
4371 int filter_has_file = IoLINES(datasv);
4372 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4373 SV *filter_state = (SV *)IoTOP_GV(datasv);
4374 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4377 /* I was having segfault trouble under Linux 2.2.5 after a
4378 parse error occured. (Had to hack around it with a test
4379 for PL_error_count == 0.) Solaris doesn't segfault --
4380 not sure where the trouble is yet. XXX */
4382 if (filter_has_file) {
4383 len = FILTER_READ(idx+1, buf_sv, maxlen);
4386 if (filter_sub && len >= 0) {
4397 PUSHs(sv_2mortal(newSViv(maxlen)));
4399 PUSHs(filter_state);
4402 count = call_sv(filter_sub, G_SCALAR);
4418 IoLINES(datasv) = 0;
4419 if (filter_child_proc) {
4420 SvREFCNT_dec(filter_child_proc);
4421 IoFMT_GV(datasv) = Nullgv;
4424 SvREFCNT_dec(filter_state);
4425 IoTOP_GV(datasv) = Nullgv;
4428 SvREFCNT_dec(filter_sub);
4429 IoBOTTOM_GV(datasv) = Nullgv;
4431 filter_del(run_user_filter);
4440 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4442 return sv_cmp_locale(str1, str2);
4446 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4448 return sv_cmp(str1, str2);
4451 #endif /* PERL_OBJECT */