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, 'r');
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, 'g'))) {
231 sv_magic(sv, Nullsv, 'g', Nullch, 0);
232 mg = mg_find(sv, 'g');
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;
320 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
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 = GvIOp(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 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1165 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1166 sv_catpv(targ, "E0");
1177 S_dopoptolabel(pTHX_ char *label)
1180 register PERL_CONTEXT *cx;
1182 for (i = cxstack_ix; i >= 0; i--) {
1184 switch (CxTYPE(cx)) {
1186 if (ckWARN(WARN_EXITING))
1187 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1188 PL_op_name[PL_op->op_type]);
1191 if (ckWARN(WARN_EXITING))
1192 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1193 PL_op_name[PL_op->op_type]);
1196 if (ckWARN(WARN_EXITING))
1197 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1198 PL_op_name[PL_op->op_type]);
1201 if (ckWARN(WARN_EXITING))
1202 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1203 PL_op_name[PL_op->op_type]);
1206 if (ckWARN(WARN_EXITING))
1207 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1208 PL_op_name[PL_op->op_type]);
1211 if (!cx->blk_loop.label ||
1212 strNE(label, cx->blk_loop.label) ) {
1213 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1214 (long)i, cx->blk_loop.label));
1217 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1225 Perl_dowantarray(pTHX)
1227 I32 gimme = block_gimme();
1228 return (gimme == G_VOID) ? G_SCALAR : gimme;
1232 Perl_block_gimme(pTHX)
1236 cxix = dopoptosub(cxstack_ix);
1240 switch (cxstack[cxix].blk_gimme) {
1248 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1255 Perl_is_lvalue_sub(pTHX)
1259 cxix = dopoptosub(cxstack_ix);
1260 assert(cxix >= 0); /* We should only be called from inside subs */
1262 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1263 return cxstack[cxix].blk_sub.lval;
1269 S_dopoptosub(pTHX_ I32 startingblock)
1271 return dopoptosub_at(cxstack, startingblock);
1275 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1278 register PERL_CONTEXT *cx;
1279 for (i = startingblock; i >= 0; i--) {
1281 switch (CxTYPE(cx)) {
1287 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1295 S_dopoptoeval(pTHX_ I32 startingblock)
1298 register PERL_CONTEXT *cx;
1299 for (i = startingblock; i >= 0; i--) {
1301 switch (CxTYPE(cx)) {
1305 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1313 S_dopoptoloop(pTHX_ I32 startingblock)
1316 register PERL_CONTEXT *cx;
1317 for (i = startingblock; i >= 0; i--) {
1319 switch (CxTYPE(cx)) {
1321 if (ckWARN(WARN_EXITING))
1322 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1323 PL_op_name[PL_op->op_type]);
1326 if (ckWARN(WARN_EXITING))
1327 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1328 PL_op_name[PL_op->op_type]);
1331 if (ckWARN(WARN_EXITING))
1332 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1333 PL_op_name[PL_op->op_type]);
1336 if (ckWARN(WARN_EXITING))
1337 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1338 PL_op_name[PL_op->op_type]);
1341 if (ckWARN(WARN_EXITING))
1342 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1343 PL_op_name[PL_op->op_type]);
1346 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1354 Perl_dounwind(pTHX_ I32 cxix)
1356 register PERL_CONTEXT *cx;
1359 while (cxstack_ix > cxix) {
1361 cx = &cxstack[cxstack_ix];
1362 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1363 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1364 /* Note: we don't need to restore the base context info till the end. */
1365 switch (CxTYPE(cx)) {
1368 continue; /* not break */
1390 Perl_qerror(pTHX_ SV *err)
1393 sv_catsv(ERRSV, err);
1395 sv_catsv(PL_errors, err);
1397 Perl_warn(aTHX_ "%"SVf, err);
1402 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1407 register PERL_CONTEXT *cx;
1412 if (PL_in_eval & EVAL_KEEPERR) {
1413 static char prefix[] = "\t(in cleanup) ";
1418 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1421 if (*e != *message || strNE(e,message))
1425 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1426 sv_catpvn(err, prefix, sizeof(prefix)-1);
1427 sv_catpvn(err, message, msglen);
1428 if (ckWARN(WARN_MISC)) {
1429 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1430 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1435 sv_setpvn(ERRSV, message, msglen);
1436 if (PL_hints & HINT_UTF8)
1443 message = SvPVx(ERRSV, msglen);
1445 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1446 && PL_curstackinfo->si_prev)
1455 if (cxix < cxstack_ix)
1458 POPBLOCK(cx,PL_curpm);
1459 if (CxTYPE(cx) != CXt_EVAL) {
1460 PerlIO_write(Perl_error_log, "panic: die ", 11);
1461 PerlIO_write(Perl_error_log, message, msglen);
1466 if (gimme == G_SCALAR)
1467 *++newsp = &PL_sv_undef;
1468 PL_stack_sp = newsp;
1472 /* LEAVE could clobber PL_curcop (see save_re_context())
1473 * XXX it might be better to find a way to avoid messing with
1474 * PL_curcop in save_re_context() instead, but this is a more
1475 * minimal fix --GSAR */
1476 PL_curcop = cx->blk_oldcop;
1478 if (optype == OP_REQUIRE) {
1479 char* msg = SvPVx(ERRSV, n_a);
1480 DIE(aTHX_ "%sCompilation failed in require",
1481 *msg ? msg : "Unknown error\n");
1483 return pop_return();
1487 message = SvPVx(ERRSV, msglen);
1490 /* SFIO can really mess with your errno */
1493 PerlIO *serr = Perl_error_log;
1495 PerlIO_write(serr, message, msglen);
1496 (void)PerlIO_flush(serr);
1509 if (SvTRUE(left) != SvTRUE(right))
1521 RETURNOP(cLOGOP->op_other);
1530 RETURNOP(cLOGOP->op_other);
1536 register I32 cxix = dopoptosub(cxstack_ix);
1537 register PERL_CONTEXT *cx;
1538 register PERL_CONTEXT *ccstack = cxstack;
1539 PERL_SI *top_si = PL_curstackinfo;
1550 /* we may be in a higher stacklevel, so dig down deeper */
1551 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1552 top_si = top_si->si_prev;
1553 ccstack = top_si->si_cxstack;
1554 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1557 if (GIMME != G_ARRAY)
1561 if (PL_DBsub && cxix >= 0 &&
1562 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1566 cxix = dopoptosub_at(ccstack, cxix - 1);
1569 cx = &ccstack[cxix];
1570 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1571 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1572 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1573 field below is defined for any cx. */
1574 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1575 cx = &ccstack[dbcxix];
1578 stashname = CopSTASHPV(cx->blk_oldcop);
1579 if (GIMME != G_ARRAY) {
1581 PUSHs(&PL_sv_undef);
1584 sv_setpv(TARG, stashname);
1591 PUSHs(&PL_sv_undef);
1593 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1594 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1595 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1598 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1599 /* So is ccstack[dbcxix]. */
1601 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1602 PUSHs(sv_2mortal(sv));
1603 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1606 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1607 PUSHs(sv_2mortal(newSViv(0)));
1609 gimme = (I32)cx->blk_gimme;
1610 if (gimme == G_VOID)
1611 PUSHs(&PL_sv_undef);
1613 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1614 if (CxTYPE(cx) == CXt_EVAL) {
1616 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1617 PUSHs(cx->blk_eval.cur_text);
1621 else if (cx->blk_eval.old_namesv) {
1622 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1625 /* eval BLOCK (try blocks have old_namesv == 0) */
1627 PUSHs(&PL_sv_undef);
1628 PUSHs(&PL_sv_undef);
1632 PUSHs(&PL_sv_undef);
1633 PUSHs(&PL_sv_undef);
1635 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1636 && CopSTASH_eq(PL_curcop, PL_debstash))
1638 AV *ary = cx->blk_sub.argarray;
1639 int off = AvARRAY(ary) - AvALLOC(ary);
1643 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1646 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1649 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1650 av_extend(PL_dbargs, AvFILLp(ary) + off);
1651 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1652 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1654 /* XXX only hints propagated via op_private are currently
1655 * visible (others are not easily accessible, since they
1656 * use the global PL_hints) */
1657 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1658 HINT_PRIVATE_MASK)));
1661 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1663 if (old_warnings == pWARN_NONE ||
1664 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1665 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1666 else if (old_warnings == pWARN_ALL ||
1667 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1668 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1670 mask = newSVsv(old_warnings);
1671 PUSHs(sv_2mortal(mask));
1686 sv_reset(tmps, CopSTASH(PL_curcop));
1698 PL_curcop = (COP*)PL_op;
1699 TAINT_NOT; /* Each statement is presumed innocent */
1700 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1703 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1707 register PERL_CONTEXT *cx;
1708 I32 gimme = G_ARRAY;
1715 DIE(aTHX_ "No DB::DB routine defined");
1717 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1718 /* don't do recursive DB::DB call */
1730 push_return(PL_op->op_next);
1731 PUSHBLOCK(cx, CXt_SUB, SP);
1734 (void)SvREFCNT_inc(cv);
1735 SAVEVPTR(PL_curpad);
1736 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1737 RETURNOP(CvSTART(cv));
1751 register PERL_CONTEXT *cx;
1752 I32 gimme = GIMME_V;
1754 U32 cxtype = CXt_LOOP;
1763 if (PL_op->op_flags & OPf_SPECIAL) {
1764 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1765 SAVEGENERICSV(*svp);
1769 #endif /* USE_THREADS */
1770 if (PL_op->op_targ) {
1771 #ifndef USE_ITHREADS
1772 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1775 SAVEPADSV(PL_op->op_targ);
1776 iterdata = (void*)PL_op->op_targ;
1777 cxtype |= CXp_PADVAR;
1782 svp = &GvSV(gv); /* symbol table variable */
1783 SAVEGENERICSV(*svp);
1786 iterdata = (void*)gv;
1792 PUSHBLOCK(cx, cxtype, SP);
1794 PUSHLOOP(cx, iterdata, MARK);
1796 PUSHLOOP(cx, svp, MARK);
1798 if (PL_op->op_flags & OPf_STACKED) {
1799 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1800 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1802 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1803 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1804 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1805 looks_like_number((SV*)cx->blk_loop.iterary) &&
1806 *SvPVX(cx->blk_loop.iterary) != '0'))
1808 if (SvNV(sv) < IV_MIN ||
1809 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1810 DIE(aTHX_ "Range iterator outside integer range");
1811 cx->blk_loop.iterix = SvIV(sv);
1812 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1815 cx->blk_loop.iterlval = newSVsv(sv);
1819 cx->blk_loop.iterary = PL_curstack;
1820 AvFILLp(PL_curstack) = SP - PL_stack_base;
1821 cx->blk_loop.iterix = MARK - PL_stack_base;
1830 register PERL_CONTEXT *cx;
1831 I32 gimme = GIMME_V;
1837 PUSHBLOCK(cx, CXt_LOOP, SP);
1838 PUSHLOOP(cx, 0, SP);
1846 register PERL_CONTEXT *cx;
1854 newsp = PL_stack_base + cx->blk_loop.resetsp;
1857 if (gimme == G_VOID)
1859 else if (gimme == G_SCALAR) {
1861 *++newsp = sv_mortalcopy(*SP);
1863 *++newsp = &PL_sv_undef;
1867 *++newsp = sv_mortalcopy(*++mark);
1868 TAINT_NOT; /* Each item is independent */
1874 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1875 PL_curpm = newpm; /* ... and pop $1 et al */
1887 register PERL_CONTEXT *cx;
1888 bool popsub2 = FALSE;
1889 bool clear_errsv = FALSE;
1896 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1897 if (cxstack_ix == PL_sortcxix
1898 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1900 if (cxstack_ix > PL_sortcxix)
1901 dounwind(PL_sortcxix);
1902 AvARRAY(PL_curstack)[1] = *SP;
1903 PL_stack_sp = PL_stack_base + 1;
1908 cxix = dopoptosub(cxstack_ix);
1910 DIE(aTHX_ "Can't return outside a subroutine");
1911 if (cxix < cxstack_ix)
1915 switch (CxTYPE(cx)) {
1920 if (!(PL_in_eval & EVAL_KEEPERR))
1926 if (optype == OP_REQUIRE &&
1927 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1929 /* Unassume the success we assumed earlier. */
1930 SV *nsv = cx->blk_eval.old_namesv;
1931 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1932 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1939 DIE(aTHX_ "panic: return");
1943 if (gimme == G_SCALAR) {
1946 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1948 *++newsp = SvREFCNT_inc(*SP);
1953 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1955 *++newsp = sv_mortalcopy(sv);
1960 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1963 *++newsp = sv_mortalcopy(*SP);
1966 *++newsp = &PL_sv_undef;
1968 else if (gimme == G_ARRAY) {
1969 while (++MARK <= SP) {
1970 *++newsp = (popsub2 && SvTEMP(*MARK))
1971 ? *MARK : sv_mortalcopy(*MARK);
1972 TAINT_NOT; /* Each item is independent */
1975 PL_stack_sp = newsp;
1977 /* Stack values are safe: */
1979 POPSUB(cx,sv); /* release CV and @_ ... */
1983 PL_curpm = newpm; /* ... and pop $1 et al */
1989 return pop_return();
1996 register PERL_CONTEXT *cx;
2006 if (PL_op->op_flags & OPf_SPECIAL) {
2007 cxix = dopoptoloop(cxstack_ix);
2009 DIE(aTHX_ "Can't \"last\" outside a loop block");
2012 cxix = dopoptolabel(cPVOP->op_pv);
2014 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2016 if (cxix < cxstack_ix)
2021 switch (CxTYPE(cx)) {
2024 newsp = PL_stack_base + cx->blk_loop.resetsp;
2025 nextop = cx->blk_loop.last_op->op_next;
2029 nextop = pop_return();
2033 nextop = pop_return();
2037 nextop = pop_return();
2040 DIE(aTHX_ "panic: last");
2044 if (gimme == G_SCALAR) {
2046 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2047 ? *SP : sv_mortalcopy(*SP);
2049 *++newsp = &PL_sv_undef;
2051 else if (gimme == G_ARRAY) {
2052 while (++MARK <= SP) {
2053 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2054 ? *MARK : sv_mortalcopy(*MARK);
2055 TAINT_NOT; /* Each item is independent */
2061 /* Stack values are safe: */
2064 POPLOOP(cx); /* release loop vars ... */
2068 POPSUB(cx,sv); /* release CV and @_ ... */
2071 PL_curpm = newpm; /* ... and pop $1 et al */
2081 register PERL_CONTEXT *cx;
2084 if (PL_op->op_flags & OPf_SPECIAL) {
2085 cxix = dopoptoloop(cxstack_ix);
2087 DIE(aTHX_ "Can't \"next\" outside a loop block");
2090 cxix = dopoptolabel(cPVOP->op_pv);
2092 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2094 if (cxix < cxstack_ix)
2097 /* clear off anything above the scope we're re-entering, but
2098 * save the rest until after a possible continue block */
2099 inner = PL_scopestack_ix;
2101 if (PL_scopestack_ix < inner)
2102 leave_scope(PL_scopestack[PL_scopestack_ix]);
2103 return cx->blk_loop.next_op;
2109 register PERL_CONTEXT *cx;
2112 if (PL_op->op_flags & OPf_SPECIAL) {
2113 cxix = dopoptoloop(cxstack_ix);
2115 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2118 cxix = dopoptolabel(cPVOP->op_pv);
2120 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2122 if (cxix < cxstack_ix)
2126 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2127 LEAVE_SCOPE(oldsave);
2128 return cx->blk_loop.redo_op;
2132 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2136 static char too_deep[] = "Target of goto is too deeply nested";
2139 Perl_croak(aTHX_ too_deep);
2140 if (o->op_type == OP_LEAVE ||
2141 o->op_type == OP_SCOPE ||
2142 o->op_type == OP_LEAVELOOP ||
2143 o->op_type == OP_LEAVETRY)
2145 *ops++ = cUNOPo->op_first;
2147 Perl_croak(aTHX_ too_deep);
2150 if (o->op_flags & OPf_KIDS) {
2151 /* First try all the kids at this level, since that's likeliest. */
2152 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2153 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2154 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2157 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2158 if (kid == PL_lastgotoprobe)
2160 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2162 (ops[-1]->op_type != OP_NEXTSTATE &&
2163 ops[-1]->op_type != OP_DBSTATE)))
2165 if ((o = dofindlabel(kid, label, ops, oplimit)))
2184 register PERL_CONTEXT *cx;
2185 #define GOTO_DEPTH 64
2186 OP *enterops[GOTO_DEPTH];
2188 int do_dump = (PL_op->op_type == OP_DUMP);
2189 static char must_have_label[] = "goto must have label";
2192 if (PL_op->op_flags & OPf_STACKED) {
2196 /* This egregious kludge implements goto &subroutine */
2197 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2199 register PERL_CONTEXT *cx;
2200 CV* cv = (CV*)SvRV(sv);
2206 if (!CvROOT(cv) && !CvXSUB(cv)) {
2211 /* autoloaded stub? */
2212 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2214 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2215 GvNAMELEN(gv), FALSE);
2216 if (autogv && (cv = GvCV(autogv)))
2218 tmpstr = sv_newmortal();
2219 gv_efullname3(tmpstr, gv, Nullch);
2220 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2222 DIE(aTHX_ "Goto undefined subroutine");
2225 /* First do some returnish stuff. */
2226 cxix = dopoptosub(cxstack_ix);
2228 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2229 if (cxix < cxstack_ix)
2232 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2233 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2235 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2236 /* put @_ back onto stack */
2237 AV* av = cx->blk_sub.argarray;
2239 items = AvFILLp(av) + 1;
2241 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2242 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2243 PL_stack_sp += items;
2245 SvREFCNT_dec(GvAV(PL_defgv));
2246 GvAV(PL_defgv) = cx->blk_sub.savearray;
2247 #endif /* USE_THREADS */
2248 /* abandon @_ if it got reified */
2250 (void)sv_2mortal((SV*)av); /* delay until return */
2252 av_extend(av, items-1);
2253 AvFLAGS(av) = AVf_REIFY;
2254 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2257 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2260 av = (AV*)PL_curpad[0];
2262 av = GvAV(PL_defgv);
2264 items = AvFILLp(av) + 1;
2266 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2267 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2268 PL_stack_sp += items;
2270 if (CxTYPE(cx) == CXt_SUB &&
2271 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2272 SvREFCNT_dec(cx->blk_sub.cv);
2273 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2274 LEAVE_SCOPE(oldsave);
2276 /* Now do some callish stuff. */
2279 #ifdef PERL_XSUB_OLDSTYLE
2280 if (CvOLDSTYLE(cv)) {
2281 I32 (*fp3)(int,int,int);
2286 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2287 items = (*fp3)(CvXSUBANY(cv).any_i32,
2288 mark - PL_stack_base + 1,
2290 SP = PL_stack_base + items;
2293 #endif /* PERL_XSUB_OLDSTYLE */
2298 PL_stack_sp--; /* There is no cv arg. */
2299 /* Push a mark for the start of arglist */
2301 (void)(*CvXSUB(cv))(aTHXo_ cv);
2302 /* Pop the current context like a decent sub should */
2303 POPBLOCK(cx, PL_curpm);
2304 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2307 return pop_return();
2310 AV* padlist = CvPADLIST(cv);
2311 SV** svp = AvARRAY(padlist);
2312 if (CxTYPE(cx) == CXt_EVAL) {
2313 PL_in_eval = cx->blk_eval.old_in_eval;
2314 PL_eval_root = cx->blk_eval.old_eval_root;
2315 cx->cx_type = CXt_SUB;
2316 cx->blk_sub.hasargs = 0;
2318 cx->blk_sub.cv = cv;
2319 cx->blk_sub.olddepth = CvDEPTH(cv);
2321 if (CvDEPTH(cv) < 2)
2322 (void)SvREFCNT_inc(cv);
2323 else { /* save temporaries on recursion? */
2324 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2325 sub_crush_depth(cv);
2326 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2327 AV *newpad = newAV();
2328 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2329 I32 ix = AvFILLp((AV*)svp[1]);
2330 I32 names_fill = AvFILLp((AV*)svp[0]);
2331 svp = AvARRAY(svp[0]);
2332 for ( ;ix > 0; ix--) {
2333 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2334 char *name = SvPVX(svp[ix]);
2335 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2338 /* outer lexical or anon code */
2339 av_store(newpad, ix,
2340 SvREFCNT_inc(oldpad[ix]) );
2342 else { /* our own lexical */
2344 av_store(newpad, ix, sv = (SV*)newAV());
2345 else if (*name == '%')
2346 av_store(newpad, ix, sv = (SV*)newHV());
2348 av_store(newpad, ix, sv = NEWSV(0,0));
2352 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2353 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2356 av_store(newpad, ix, sv = NEWSV(0,0));
2360 if (cx->blk_sub.hasargs) {
2363 av_store(newpad, 0, (SV*)av);
2364 AvFLAGS(av) = AVf_REIFY;
2366 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2367 AvFILLp(padlist) = CvDEPTH(cv);
2368 svp = AvARRAY(padlist);
2372 if (!cx->blk_sub.hasargs) {
2373 AV* av = (AV*)PL_curpad[0];
2375 items = AvFILLp(av) + 1;
2377 /* Mark is at the end of the stack. */
2379 Copy(AvARRAY(av), SP + 1, items, SV*);
2384 #endif /* USE_THREADS */
2385 SAVEVPTR(PL_curpad);
2386 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2388 if (cx->blk_sub.hasargs)
2389 #endif /* USE_THREADS */
2391 AV* av = (AV*)PL_curpad[0];
2395 cx->blk_sub.savearray = GvAV(PL_defgv);
2396 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2397 #endif /* USE_THREADS */
2398 cx->blk_sub.oldcurpad = PL_curpad;
2399 cx->blk_sub.argarray = av;
2402 if (items >= AvMAX(av) + 1) {
2404 if (AvARRAY(av) != ary) {
2405 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2406 SvPVX(av) = (char*)ary;
2408 if (items >= AvMAX(av) + 1) {
2409 AvMAX(av) = items - 1;
2410 Renew(ary,items+1,SV*);
2412 SvPVX(av) = (char*)ary;
2415 Copy(mark,AvARRAY(av),items,SV*);
2416 AvFILLp(av) = items - 1;
2417 assert(!AvREAL(av));
2424 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2426 * We do not care about using sv to call CV;
2427 * it's for informational purposes only.
2429 SV *sv = GvSV(PL_DBsub);
2432 if (PERLDB_SUB_NN) {
2433 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2436 gv_efullname3(sv, CvGV(cv), Nullch);
2439 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2440 PUSHMARK( PL_stack_sp );
2441 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2445 RETURNOP(CvSTART(cv));
2449 label = SvPV(sv,n_a);
2450 if (!(do_dump || *label))
2451 DIE(aTHX_ must_have_label);
2454 else if (PL_op->op_flags & OPf_SPECIAL) {
2456 DIE(aTHX_ must_have_label);
2459 label = cPVOP->op_pv;
2461 if (label && *label) {
2463 bool leaving_eval = FALSE;
2464 PERL_CONTEXT *last_eval_cx = 0;
2468 PL_lastgotoprobe = 0;
2470 for (ix = cxstack_ix; ix >= 0; ix--) {
2472 switch (CxTYPE(cx)) {
2474 leaving_eval = TRUE;
2475 if (CxREALEVAL(cx)) {
2476 gotoprobe = (last_eval_cx ?
2477 last_eval_cx->blk_eval.old_eval_root :
2482 /* else fall through */
2484 gotoprobe = cx->blk_oldcop->op_sibling;
2490 gotoprobe = cx->blk_oldcop->op_sibling;
2492 gotoprobe = PL_main_root;
2495 if (CvDEPTH(cx->blk_sub.cv)) {
2496 gotoprobe = CvROOT(cx->blk_sub.cv);
2502 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2505 DIE(aTHX_ "panic: goto");
2506 gotoprobe = PL_main_root;
2510 retop = dofindlabel(gotoprobe, label,
2511 enterops, enterops + GOTO_DEPTH);
2515 PL_lastgotoprobe = gotoprobe;
2518 DIE(aTHX_ "Can't find label %s", label);
2520 /* if we're leaving an eval, check before we pop any frames
2521 that we're not going to punt, otherwise the error
2524 if (leaving_eval && *enterops && enterops[1]) {
2526 for (i = 1; enterops[i]; i++)
2527 if (enterops[i]->op_type == OP_ENTERITER)
2528 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2531 /* pop unwanted frames */
2533 if (ix < cxstack_ix) {
2540 oldsave = PL_scopestack[PL_scopestack_ix];
2541 LEAVE_SCOPE(oldsave);
2544 /* push wanted frames */
2546 if (*enterops && enterops[1]) {
2548 for (ix = 1; enterops[ix]; ix++) {
2549 PL_op = enterops[ix];
2550 /* Eventually we may want to stack the needed arguments
2551 * for each op. For now, we punt on the hard ones. */
2552 if (PL_op->op_type == OP_ENTERITER)
2553 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2554 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2562 if (!retop) retop = PL_main_start;
2564 PL_restartop = retop;
2565 PL_do_undump = TRUE;
2569 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2570 PL_do_undump = FALSE;
2586 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2590 PL_exit_flags |= PERL_EXIT_EXPECTED;
2592 PUSHs(&PL_sv_undef);
2600 NV value = SvNVx(GvSV(cCOP->cop_gv));
2601 register I32 match = I_32(value);
2604 if (((NV)match) > value)
2605 --match; /* was fractional--truncate other way */
2607 match -= cCOP->uop.scop.scop_offset;
2610 else if (match > cCOP->uop.scop.scop_max)
2611 match = cCOP->uop.scop.scop_max;
2612 PL_op = cCOP->uop.scop.scop_next[match];
2622 PL_op = PL_op->op_next; /* can't assume anything */
2625 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2626 match -= cCOP->uop.scop.scop_offset;
2629 else if (match > cCOP->uop.scop.scop_max)
2630 match = cCOP->uop.scop.scop_max;
2631 PL_op = cCOP->uop.scop.scop_next[match];
2640 S_save_lines(pTHX_ AV *array, SV *sv)
2642 register char *s = SvPVX(sv);
2643 register char *send = SvPVX(sv) + SvCUR(sv);
2645 register I32 line = 1;
2647 while (s && s < send) {
2648 SV *tmpstr = NEWSV(85,0);
2650 sv_upgrade(tmpstr, SVt_PVMG);
2651 t = strchr(s, '\n');
2657 sv_setpvn(tmpstr, s, t - s);
2658 av_store(array, line++, tmpstr);
2663 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2665 S_docatch_body(pTHX_ va_list args)
2667 return docatch_body();
2672 S_docatch_body(pTHX)
2679 S_docatch(pTHX_ OP *o)
2683 volatile PERL_SI *cursi = PL_curstackinfo;
2687 assert(CATCH_GET == TRUE);
2690 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2692 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2698 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2704 if (PL_restartop && cursi == PL_curstackinfo) {
2705 PL_op = PL_restartop;
2722 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2723 /* sv Text to convert to OP tree. */
2724 /* startop op_free() this to undo. */
2725 /* code Short string id of the caller. */
2727 dSP; /* Make POPBLOCK work. */
2730 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2734 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2735 char *tmpbuf = tbuf;
2741 /* switch to eval mode */
2743 if (PL_curcop == &PL_compiling) {
2744 SAVECOPSTASH_FREE(&PL_compiling);
2745 CopSTASH_set(&PL_compiling, PL_curstash);
2747 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2748 SV *sv = sv_newmortal();
2749 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2750 code, (unsigned long)++PL_evalseq,
2751 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2755 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2756 SAVECOPFILE_FREE(&PL_compiling);
2757 CopFILE_set(&PL_compiling, tmpbuf+2);
2758 SAVECOPLINE(&PL_compiling);
2759 CopLINE_set(&PL_compiling, 1);
2760 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2761 deleting the eval's FILEGV from the stash before gv_check() runs
2762 (i.e. before run-time proper). To work around the coredump that
2763 ensues, we always turn GvMULTI_on for any globals that were
2764 introduced within evals. See force_ident(). GSAR 96-10-12 */
2765 safestr = savepv(tmpbuf);
2766 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2768 #ifdef OP_IN_REGISTER
2773 PL_hints &= HINT_UTF8;
2776 PL_op->op_type = OP_ENTEREVAL;
2777 PL_op->op_flags = 0; /* Avoid uninit warning. */
2778 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2779 PUSHEVAL(cx, 0, Nullgv);
2780 rop = doeval(G_SCALAR, startop);
2781 POPBLOCK(cx,PL_curpm);
2784 (*startop)->op_type = OP_NULL;
2785 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2787 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2789 if (PL_curcop == &PL_compiling)
2790 PL_compiling.op_private = PL_hints;
2791 #ifdef OP_IN_REGISTER
2797 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2799 S_doeval(pTHX_ int gimme, OP** startop)
2807 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2808 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2813 /* set up a scratch pad */
2816 SAVEVPTR(PL_curpad);
2817 SAVESPTR(PL_comppad);
2818 SAVESPTR(PL_comppad_name);
2819 SAVEI32(PL_comppad_name_fill);
2820 SAVEI32(PL_min_intro_pending);
2821 SAVEI32(PL_max_intro_pending);
2824 for (i = cxstack_ix - 1; i >= 0; i--) {
2825 PERL_CONTEXT *cx = &cxstack[i];
2826 if (CxTYPE(cx) == CXt_EVAL)
2828 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2829 caller = cx->blk_sub.cv;
2834 SAVESPTR(PL_compcv);
2835 PL_compcv = (CV*)NEWSV(1104,0);
2836 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2837 CvEVAL_on(PL_compcv);
2839 CvOWNER(PL_compcv) = 0;
2840 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2841 MUTEX_INIT(CvMUTEXP(PL_compcv));
2842 #endif /* USE_THREADS */
2844 PL_comppad = newAV();
2845 av_push(PL_comppad, Nullsv);
2846 PL_curpad = AvARRAY(PL_comppad);
2847 PL_comppad_name = newAV();
2848 PL_comppad_name_fill = 0;
2849 PL_min_intro_pending = 0;
2852 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2853 PL_curpad[0] = (SV*)newAV();
2854 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2855 #endif /* USE_THREADS */
2857 comppadlist = newAV();
2858 AvREAL_off(comppadlist);
2859 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2860 av_store(comppadlist, 1, (SV*)PL_comppad);
2861 CvPADLIST(PL_compcv) = comppadlist;
2864 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2866 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2869 SAVEFREESV(PL_compcv);
2871 /* make sure we compile in the right package */
2873 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2874 SAVESPTR(PL_curstash);
2875 PL_curstash = CopSTASH(PL_curcop);
2877 SAVESPTR(PL_beginav);
2878 PL_beginav = newAV();
2879 SAVEFREESV(PL_beginav);
2880 SAVEI32(PL_error_count);
2882 /* try to compile it */
2884 PL_eval_root = Nullop;
2886 PL_curcop = &PL_compiling;
2887 PL_curcop->cop_arybase = 0;
2888 SvREFCNT_dec(PL_rs);
2889 PL_rs = newSVpvn("\n", 1);
2890 if (saveop && saveop->op_flags & OPf_SPECIAL)
2891 PL_in_eval |= EVAL_KEEPERR;
2894 if (yyparse() || PL_error_count || !PL_eval_root) {
2898 I32 optype = 0; /* Might be reset by POPEVAL. */
2903 op_free(PL_eval_root);
2904 PL_eval_root = Nullop;
2906 SP = PL_stack_base + POPMARK; /* pop original mark */
2908 POPBLOCK(cx,PL_curpm);
2914 if (optype == OP_REQUIRE) {
2915 char* msg = SvPVx(ERRSV, n_a);
2916 DIE(aTHX_ "%sCompilation failed in require",
2917 *msg ? msg : "Unknown error\n");
2920 char* msg = SvPVx(ERRSV, n_a);
2922 POPBLOCK(cx,PL_curpm);
2924 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2925 (*msg ? msg : "Unknown error\n"));
2927 SvREFCNT_dec(PL_rs);
2928 PL_rs = SvREFCNT_inc(PL_nrs);
2930 MUTEX_LOCK(&PL_eval_mutex);
2932 COND_SIGNAL(&PL_eval_cond);
2933 MUTEX_UNLOCK(&PL_eval_mutex);
2934 #endif /* USE_THREADS */
2937 SvREFCNT_dec(PL_rs);
2938 PL_rs = SvREFCNT_inc(PL_nrs);
2939 CopLINE_set(&PL_compiling, 0);
2941 *startop = PL_eval_root;
2942 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2943 CvOUTSIDE(PL_compcv) = Nullcv;
2945 SAVEFREEOP(PL_eval_root);
2947 scalarvoid(PL_eval_root);
2948 else if (gimme & G_ARRAY)
2951 scalar(PL_eval_root);
2953 DEBUG_x(dump_eval());
2955 /* Register with debugger: */
2956 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2957 CV *cv = get_cv("DB::postponed", FALSE);
2961 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2963 call_sv((SV*)cv, G_DISCARD);
2967 /* compiled okay, so do it */
2969 CvDEPTH(PL_compcv) = 1;
2970 SP = PL_stack_base + POPMARK; /* pop original mark */
2971 PL_op = saveop; /* The caller may need it. */
2972 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2974 MUTEX_LOCK(&PL_eval_mutex);
2976 COND_SIGNAL(&PL_eval_cond);
2977 MUTEX_UNLOCK(&PL_eval_mutex);
2978 #endif /* USE_THREADS */
2980 RETURNOP(PL_eval_start);
2984 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2986 STRLEN namelen = strlen(name);
2989 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2990 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2991 char *pmc = SvPV_nolen(pmcsv);
2994 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2995 fp = PerlIO_open(name, mode);
2998 if (PerlLIO_stat(name, &pmstat) < 0 ||
2999 pmstat.st_mtime < pmcstat.st_mtime)
3001 fp = PerlIO_open(pmc, mode);
3004 fp = PerlIO_open(name, mode);
3007 SvREFCNT_dec(pmcsv);
3010 fp = PerlIO_open(name, mode);
3018 register PERL_CONTEXT *cx;
3023 SV *namesv = Nullsv;
3025 I32 gimme = G_SCALAR;
3026 PerlIO *tryrsfp = 0;
3028 int filter_has_file = 0;
3029 GV *filter_child_proc = 0;
3030 SV *filter_state = 0;
3035 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3036 UV rev = 0, ver = 0, sver = 0;
3038 U8 *s = (U8*)SvPVX(sv);
3039 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3041 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3044 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3047 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3050 if (PERL_REVISION < rev
3051 || (PERL_REVISION == rev
3052 && (PERL_VERSION < ver
3053 || (PERL_VERSION == ver
3054 && PERL_SUBVERSION < sver))))
3056 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3057 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3058 PERL_VERSION, PERL_SUBVERSION);
3062 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3063 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3064 + ((NV)PERL_SUBVERSION/(NV)1000000)
3065 + 0.00000099 < SvNV(sv))
3069 NV nver = (nrev - rev) * 1000;
3070 UV ver = (UV)(nver + 0.0009);
3071 NV nsver = (nver - ver) * 1000;
3072 UV sver = (UV)(nsver + 0.0009);
3074 /* help out with the "use 5.6" confusion */
3075 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3076 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3077 "this is only v%d.%d.%d, stopped"
3078 " (did you mean v%"UVuf".%"UVuf".0?)",
3079 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3080 PERL_SUBVERSION, rev, ver/100);
3083 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3084 "this is only v%d.%d.%d, stopped",
3085 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3092 name = SvPV(sv, len);
3093 if (!(name && len > 0 && *name))
3094 DIE(aTHX_ "Null filename used");
3095 TAINT_PROPER("require");
3096 if (PL_op->op_type == OP_REQUIRE &&
3097 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3098 *svp != &PL_sv_undef)
3101 /* prepare to compile file */
3103 #ifdef MACOS_TRADITIONAL
3104 if (PERL_FILE_IS_ABSOLUTE(name)
3105 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3108 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3109 /* We consider paths of the form :a:b ambiguous and interpret them first
3110 as global then as local
3112 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3118 if (PERL_FILE_IS_ABSOLUTE(name)
3119 || (*name == '.' && (name[1] == '/' ||
3120 (name[1] == '.' && name[2] == '/'))))
3123 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3127 AV *ar = GvAVn(PL_incgv);
3131 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3134 namesv = NEWSV(806, 0);
3135 for (i = 0; i <= AvFILL(ar); i++) {
3136 SV *dirsv = *av_fetch(ar, i, TRUE);
3142 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3143 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3146 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3147 PTR2UV(SvANY(loader)), name);
3148 tryname = SvPVX(namesv);
3159 if (sv_isobject(loader))
3160 count = call_method("INC", G_ARRAY);
3162 count = call_sv(loader, G_ARRAY);
3172 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3176 if (SvTYPE(arg) == SVt_PVGV) {
3177 IO *io = GvIO((GV *)arg);
3182 tryrsfp = IoIFP(io);
3183 if (IoTYPE(io) == IoTYPE_PIPE) {
3184 /* reading from a child process doesn't
3185 nest -- when returning from reading
3186 the inner module, the outer one is
3187 unreadable (closed?) I've tried to
3188 save the gv to manage the lifespan of
3189 the pipe, but this didn't help. XXX */
3190 filter_child_proc = (GV *)arg;
3191 (void)SvREFCNT_inc(filter_child_proc);
3194 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3195 PerlIO_close(IoOFP(io));
3207 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3209 (void)SvREFCNT_inc(filter_sub);
3212 filter_state = SP[i];
3213 (void)SvREFCNT_inc(filter_state);
3217 tryrsfp = PerlIO_open("/dev/null",
3231 filter_has_file = 0;
3232 if (filter_child_proc) {
3233 SvREFCNT_dec(filter_child_proc);
3234 filter_child_proc = 0;
3237 SvREFCNT_dec(filter_state);
3241 SvREFCNT_dec(filter_sub);
3246 char *dir = SvPVx(dirsv, n_a);
3247 #ifdef MACOS_TRADITIONAL
3249 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3253 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3255 sv_setpv(namesv, unixdir);
3256 sv_catpv(namesv, unixname);
3258 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3261 TAINT_PROPER("require");
3262 tryname = SvPVX(namesv);
3263 #ifdef MACOS_TRADITIONAL
3265 /* Convert slashes in the name part, but not the directory part, to colons */
3267 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3271 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3273 if (tryname[0] == '.' && tryname[1] == '/')
3281 SAVECOPFILE_FREE(&PL_compiling);
3282 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3283 SvREFCNT_dec(namesv);
3285 if (PL_op->op_type == OP_REQUIRE) {
3286 char *msgstr = name;
3287 if (namesv) { /* did we lookup @INC? */
3288 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3289 SV *dirmsgsv = NEWSV(0, 0);
3290 AV *ar = GvAVn(PL_incgv);
3292 sv_catpvn(msg, " in @INC", 8);
3293 if (instr(SvPVX(msg), ".h "))
3294 sv_catpv(msg, " (change .h to .ph maybe?)");
3295 if (instr(SvPVX(msg), ".ph "))
3296 sv_catpv(msg, " (did you run h2ph?)");
3297 sv_catpv(msg, " (@INC contains:");
3298 for (i = 0; i <= AvFILL(ar); i++) {
3299 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3300 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3301 sv_catsv(msg, dirmsgsv);
3303 sv_catpvn(msg, ")", 1);
3304 SvREFCNT_dec(dirmsgsv);
3305 msgstr = SvPV_nolen(msg);
3307 DIE(aTHX_ "Can't locate %s", msgstr);
3313 SETERRNO(0, SS$_NORMAL);
3315 /* Assume success here to prevent recursive requirement. */
3316 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3317 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3321 lex_start(sv_2mortal(newSVpvn("",0)));
3322 SAVEGENERICSV(PL_rsfp_filters);
3323 PL_rsfp_filters = Nullav;
3328 SAVESPTR(PL_compiling.cop_warnings);
3329 if (PL_dowarn & G_WARN_ALL_ON)
3330 PL_compiling.cop_warnings = pWARN_ALL ;
3331 else if (PL_dowarn & G_WARN_ALL_OFF)
3332 PL_compiling.cop_warnings = pWARN_NONE ;
3334 PL_compiling.cop_warnings = pWARN_STD ;
3335 SAVESPTR(PL_compiling.cop_io);
3336 PL_compiling.cop_io = Nullsv;
3338 if (filter_sub || filter_child_proc) {
3339 SV *datasv = filter_add(run_user_filter, Nullsv);
3340 IoLINES(datasv) = filter_has_file;
3341 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3342 IoTOP_GV(datasv) = (GV *)filter_state;
3343 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3346 /* switch to eval mode */
3347 push_return(PL_op->op_next);
3348 PUSHBLOCK(cx, CXt_EVAL, SP);
3349 PUSHEVAL(cx, name, Nullgv);
3351 SAVECOPLINE(&PL_compiling);
3352 CopLINE_set(&PL_compiling, 0);
3356 MUTEX_LOCK(&PL_eval_mutex);
3357 if (PL_eval_owner && PL_eval_owner != thr)
3358 while (PL_eval_owner)
3359 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3360 PL_eval_owner = thr;
3361 MUTEX_UNLOCK(&PL_eval_mutex);
3362 #endif /* USE_THREADS */
3363 return DOCATCH(doeval(G_SCALAR, NULL));
3368 return pp_require();
3374 register PERL_CONTEXT *cx;
3376 I32 gimme = GIMME_V, was = PL_sub_generation;
3377 char tbuf[TYPE_DIGITS(long) + 12];
3378 char *tmpbuf = tbuf;
3383 if (!SvPV(sv,len) || !len)
3385 TAINT_PROPER("eval");
3391 /* switch to eval mode */
3393 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3394 SV *sv = sv_newmortal();
3395 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3396 (unsigned long)++PL_evalseq,
3397 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3401 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3402 SAVECOPFILE_FREE(&PL_compiling);
3403 CopFILE_set(&PL_compiling, tmpbuf+2);
3404 SAVECOPLINE(&PL_compiling);
3405 CopLINE_set(&PL_compiling, 1);
3406 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3407 deleting the eval's FILEGV from the stash before gv_check() runs
3408 (i.e. before run-time proper). To work around the coredump that
3409 ensues, we always turn GvMULTI_on for any globals that were
3410 introduced within evals. See force_ident(). GSAR 96-10-12 */
3411 safestr = savepv(tmpbuf);
3412 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3414 PL_hints = PL_op->op_targ;
3415 SAVESPTR(PL_compiling.cop_warnings);
3416 if (specialWARN(PL_curcop->cop_warnings))
3417 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3419 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3420 SAVEFREESV(PL_compiling.cop_warnings);
3422 SAVESPTR(PL_compiling.cop_io);
3423 if (specialCopIO(PL_curcop->cop_io))
3424 PL_compiling.cop_io = PL_curcop->cop_io;
3426 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3427 SAVEFREESV(PL_compiling.cop_io);
3430 push_return(PL_op->op_next);
3431 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3432 PUSHEVAL(cx, 0, Nullgv);
3434 /* prepare to compile string */
3436 if (PERLDB_LINE && PL_curstash != PL_debstash)
3437 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3440 MUTEX_LOCK(&PL_eval_mutex);
3441 if (PL_eval_owner && PL_eval_owner != thr)
3442 while (PL_eval_owner)
3443 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3444 PL_eval_owner = thr;
3445 MUTEX_UNLOCK(&PL_eval_mutex);
3446 #endif /* USE_THREADS */
3447 ret = doeval(gimme, NULL);
3448 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3449 && ret != PL_op->op_next) { /* Successive compilation. */
3450 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3452 return DOCATCH(ret);
3462 register PERL_CONTEXT *cx;
3464 U8 save_flags = PL_op -> op_flags;
3469 retop = pop_return();
3472 if (gimme == G_VOID)
3474 else if (gimme == G_SCALAR) {
3477 if (SvFLAGS(TOPs) & SVs_TEMP)
3480 *MARK = sv_mortalcopy(TOPs);
3484 *MARK = &PL_sv_undef;
3489 /* in case LEAVE wipes old return values */
3490 for (mark = newsp + 1; mark <= SP; mark++) {
3491 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3492 *mark = sv_mortalcopy(*mark);
3493 TAINT_NOT; /* Each item is independent */
3497 PL_curpm = newpm; /* Don't pop $1 et al till now */
3500 assert(CvDEPTH(PL_compcv) == 1);
3502 CvDEPTH(PL_compcv) = 0;
3505 if (optype == OP_REQUIRE &&
3506 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3508 /* Unassume the success we assumed earlier. */
3509 SV *nsv = cx->blk_eval.old_namesv;
3510 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3511 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3512 /* die_where() did LEAVE, or we won't be here */
3516 if (!(save_flags & OPf_SPECIAL))
3526 register PERL_CONTEXT *cx;
3527 I32 gimme = GIMME_V;
3532 push_return(cLOGOP->op_other->op_next);
3533 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3536 PL_in_eval = EVAL_INEVAL;
3539 return DOCATCH(PL_op->op_next);
3549 register PERL_CONTEXT *cx;
3557 if (gimme == G_VOID)
3559 else if (gimme == G_SCALAR) {
3562 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3565 *MARK = sv_mortalcopy(TOPs);
3569 *MARK = &PL_sv_undef;
3574 /* in case LEAVE wipes old return values */
3575 for (mark = newsp + 1; mark <= SP; mark++) {
3576 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3577 *mark = sv_mortalcopy(*mark);
3578 TAINT_NOT; /* Each item is independent */
3582 PL_curpm = newpm; /* Don't pop $1 et al till now */
3590 S_doparseform(pTHX_ SV *sv)
3593 register char *s = SvPV_force(sv, len);
3594 register char *send = s + len;
3595 register char *base;
3596 register I32 skipspaces = 0;
3599 bool postspace = FALSE;
3607 Perl_croak(aTHX_ "Null picture in formline");
3609 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3614 *fpc++ = FF_LINEMARK;
3615 noblank = repeat = FALSE;
3633 case ' ': case '\t':
3644 *fpc++ = FF_LITERAL;
3652 *fpc++ = skipspaces;
3656 *fpc++ = FF_NEWLINE;
3660 arg = fpc - linepc + 1;
3667 *fpc++ = FF_LINEMARK;
3668 noblank = repeat = FALSE;
3677 ischop = s[-1] == '^';
3683 arg = (s - base) - 1;
3685 *fpc++ = FF_LITERAL;
3694 *fpc++ = FF_LINEGLOB;
3696 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3697 arg = ischop ? 512 : 0;
3707 arg |= 256 + (s - f);
3709 *fpc++ = s - base; /* fieldsize for FETCH */
3710 *fpc++ = FF_DECIMAL;
3713 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3714 arg = ischop ? 512 : 0;
3716 s++; /* skip the '0' first */
3725 arg |= 256 + (s - f);
3727 *fpc++ = s - base; /* fieldsize for FETCH */
3728 *fpc++ = FF_0DECIMAL;
3733 bool ismore = FALSE;
3736 while (*++s == '>') ;
3737 prespace = FF_SPACE;
3739 else if (*s == '|') {
3740 while (*++s == '|') ;
3741 prespace = FF_HALFSPACE;
3746 while (*++s == '<') ;
3749 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3753 *fpc++ = s - base; /* fieldsize for FETCH */
3755 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3773 { /* need to jump to the next word */
3775 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3776 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3777 s = SvPVX(sv) + SvCUR(sv) + z;
3779 Copy(fops, s, arg, U16);
3781 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3786 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3788 * The original code was written in conjunction with BSD Computer Software
3789 * Research Group at University of California, Berkeley.
3791 * See also: "Optimistic Merge Sort" (SODA '92)
3793 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3795 * The code can be distributed under the same terms as Perl itself.
3800 #include <sys/types.h>
3805 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3806 #define Safefree(VAR) free(VAR)
3807 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3808 #endif /* TESTHARNESS */
3810 typedef char * aptr; /* pointer for arithmetic on sizes */
3811 typedef SV * gptr; /* pointers in our lists */
3813 /* Binary merge internal sort, with a few special mods
3814 ** for the special perl environment it now finds itself in.
3816 ** Things that were once options have been hotwired
3817 ** to values suitable for this use. In particular, we'll always
3818 ** initialize looking for natural runs, we'll always produce stable
3819 ** output, and we'll always do Peter McIlroy's binary merge.
3822 /* Pointer types for arithmetic and storage and convenience casts */
3824 #define APTR(P) ((aptr)(P))
3825 #define GPTP(P) ((gptr *)(P))
3826 #define GPPP(P) ((gptr **)(P))
3829 /* byte offset from pointer P to (larger) pointer Q */
3830 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3832 #define PSIZE sizeof(gptr)
3834 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3837 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3838 #define PNBYTE(N) ((N) << (PSHIFT))
3839 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3841 /* Leave optimization to compiler */
3842 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3843 #define PNBYTE(N) ((N) * (PSIZE))
3844 #define PINDEX(P, N) (GPTP(P) + (N))
3847 /* Pointer into other corresponding to pointer into this */
3848 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3850 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3853 /* Runs are identified by a pointer in the auxilliary list.
3854 ** The pointer is at the start of the list,
3855 ** and it points to the start of the next list.
3856 ** NEXT is used as an lvalue, too.
3859 #define NEXT(P) (*GPPP(P))
3862 /* PTHRESH is the minimum number of pairs with the same sense to justify
3863 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3864 ** not just elements, so PTHRESH == 8 means a run of 16.
3869 /* RTHRESH is the number of elements in a run that must compare low
3870 ** to the low element from the opposing run before we justify
3871 ** doing a binary rampup instead of single stepping.
3872 ** In random input, N in a row low should only happen with
3873 ** probability 2^(1-N), so we can risk that we are dealing
3874 ** with orderly input without paying much when we aren't.
3881 ** Overview of algorithm and variables.
3882 ** The array of elements at list1 will be organized into runs of length 2,
3883 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3884 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3886 ** Unless otherwise specified, pair pointers address the first of two elements.
3888 ** b and b+1 are a pair that compare with sense ``sense''.
3889 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3891 ** p2 parallels b in the list2 array, where runs are defined by
3894 ** t represents the ``top'' of the adjacent pairs that might extend
3895 ** the run beginning at b. Usually, t addresses a pair
3896 ** that compares with opposite sense from (b,b+1).
3897 ** However, it may also address a singleton element at the end of list1,
3898 ** or it may be equal to ``last'', the first element beyond list1.
3900 ** r addresses the Nth pair following b. If this would be beyond t,
3901 ** we back it off to t. Only when r is less than t do we consider the
3902 ** run long enough to consider checking.
3904 ** q addresses a pair such that the pairs at b through q already form a run.
3905 ** Often, q will equal b, indicating we only are sure of the pair itself.
3906 ** However, a search on the previous cycle may have revealed a longer run,
3907 ** so q may be greater than b.
3909 ** p is used to work back from a candidate r, trying to reach q,
3910 ** which would mean b through r would be a run. If we discover such a run,
3911 ** we start q at r and try to push it further towards t.
3912 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3913 ** In any event, after the check (if any), we have two main cases.
3915 ** 1) Short run. b <= q < p <= r <= t.
3916 ** b through q is a run (perhaps trivial)
3917 ** q through p are uninteresting pairs
3918 ** p through r is a run
3920 ** 2) Long run. b < r <= q < t.
3921 ** b through q is a run (of length >= 2 * PTHRESH)
3923 ** Note that degenerate cases are not only possible, but likely.
3924 ** For example, if the pair following b compares with opposite sense,
3925 ** then b == q < p == r == t.
3930 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3933 register gptr *b, *p, *q, *t, *p2;
3934 register gptr c, *last, *r;
3938 last = PINDEX(b, nmemb);
3939 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3940 for (p2 = list2; b < last; ) {
3941 /* We just started, or just reversed sense.
3942 ** Set t at end of pairs with the prevailing sense.
3944 for (p = b+2, t = p; ++p < last; t = ++p) {
3945 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3948 /* Having laid out the playing field, look for long runs */
3950 p = r = b + (2 * PTHRESH);
3951 if (r >= t) p = r = t; /* too short to care about */
3953 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3956 /* b through r is a (long) run.
3957 ** Extend it as far as possible.
3960 while (((p += 2) < t) &&
3961 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3962 r = p = q + 2; /* no simple pairs, no after-run */
3965 if (q > b) { /* run of greater than 2 at b */
3968 /* pick up singleton, if possible */
3970 ((t + 1) == last) &&
3971 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3972 savep = r = p = q = last;
3973 p2 = NEXT(p2) = p2 + (p - b);
3974 if (sense) while (b < --p) {
3981 while (q < p) { /* simple pairs */
3982 p2 = NEXT(p2) = p2 + 2;
3989 if (((b = p) == t) && ((t+1) == last)) {
4001 /* Overview of bmerge variables:
4003 ** list1 and list2 address the main and auxiliary arrays.
4004 ** They swap identities after each merge pass.
4005 ** Base points to the original list1, so we can tell if
4006 ** the pointers ended up where they belonged (or must be copied).
4008 ** When we are merging two lists, f1 and f2 are the next elements
4009 ** on the respective lists. l1 and l2 mark the end of the lists.
4010 ** tp2 is the current location in the merged list.
4012 ** p1 records where f1 started.
4013 ** After the merge, a new descriptor is built there.
4015 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4016 ** It is used to identify and delimit the runs.
4018 ** In the heat of determining where q, the greater of the f1/f2 elements,
4019 ** belongs in the other list, b, t and p, represent bottom, top and probe
4020 ** locations, respectively, in the other list.
4021 ** They make convenient temporary pointers in other places.
4025 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4029 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4030 gptr *aux, *list2, *p2, *last;
4034 if (nmemb <= 1) return; /* sorted trivially */
4035 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4037 dynprep(aTHX_ list1, list2, nmemb, cmp);
4038 last = PINDEX(list2, nmemb);
4039 while (NEXT(list2) != last) {
4040 /* More than one run remains. Do some merging to reduce runs. */
4042 for (tp2 = p2 = list2; p2 != last;) {
4043 /* The new first run begins where the old second list ended.
4044 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4048 f2 = l1 = POTHER(t, list2, list1);
4049 if (t != last) t = NEXT(t);
4050 l2 = POTHER(t, list2, list1);
4052 while (f1 < l1 && f2 < l2) {
4053 /* If head 1 is larger than head 2, find ALL the elements
4054 ** in list 2 strictly less than head1, write them all,
4055 ** then head 1. Then compare the new heads, and repeat,
4056 ** until one or both lists are exhausted.
4058 ** In all comparisons (after establishing
4059 ** which head to merge) the item to merge
4060 ** (at pointer q) is the first operand of
4061 ** the comparison. When we want to know
4062 ** if ``q is strictly less than the other'',
4064 ** cmp(q, other) < 0
4065 ** because stability demands that we treat equality
4066 ** as high when q comes from l2, and as low when
4067 ** q was from l1. So we ask the question by doing
4068 ** cmp(q, other) <= sense
4069 ** and make sense == 0 when equality should look low,
4070 ** and -1 when equality should look high.
4074 if (cmp(aTHX_ *f1, *f2) <= 0) {
4075 q = f2; b = f1; t = l1;
4078 q = f1; b = f2; t = l2;
4085 ** Leave t at something strictly
4086 ** greater than q (or at the end of the list),
4087 ** and b at something strictly less than q.
4089 for (i = 1, run = 0 ;;) {
4090 if ((p = PINDEX(b, i)) >= t) {
4092 if (((p = PINDEX(t, -1)) > b) &&
4093 (cmp(aTHX_ *q, *p) <= sense))
4097 } else if (cmp(aTHX_ *q, *p) <= sense) {
4101 if (++run >= RTHRESH) i += i;
4105 /* q is known to follow b and must be inserted before t.
4106 ** Increment b, so the range of possibilities is [b,t).
4107 ** Round binary split down, to favor early appearance.
4108 ** Adjust b and t until q belongs just before t.
4113 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4114 if (cmp(aTHX_ *q, *p) <= sense) {
4120 /* Copy all the strictly low elements */
4123 FROMTOUPTO(f2, tp2, t);
4126 FROMTOUPTO(f1, tp2, t);
4132 /* Run out remaining list */
4134 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4135 } else FROMTOUPTO(f1, tp2, l1);
4136 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4141 last = PINDEX(list2, nmemb);
4143 if (base == list2) {
4144 last = PINDEX(list1, nmemb);
4145 FROMTOUPTO(list1, list2, last);
4160 sortcv(pTHXo_ SV *a, SV *b)
4162 I32 oldsaveix = PL_savestack_ix;
4163 I32 oldscopeix = PL_scopestack_ix;
4165 GvSV(PL_firstgv) = a;
4166 GvSV(PL_secondgv) = b;
4167 PL_stack_sp = PL_stack_base;
4170 if (PL_stack_sp != PL_stack_base + 1)
4171 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4172 if (!SvNIOKp(*PL_stack_sp))
4173 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4174 result = SvIV(*PL_stack_sp);
4175 while (PL_scopestack_ix > oldscopeix) {
4178 leave_scope(oldsaveix);
4183 sortcv_stacked(pTHXo_ SV *a, SV *b)
4185 I32 oldsaveix = PL_savestack_ix;
4186 I32 oldscopeix = PL_scopestack_ix;
4191 av = (AV*)PL_curpad[0];
4193 av = GvAV(PL_defgv);
4196 if (AvMAX(av) < 1) {
4197 SV** ary = AvALLOC(av);
4198 if (AvARRAY(av) != ary) {
4199 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4200 SvPVX(av) = (char*)ary;
4202 if (AvMAX(av) < 1) {
4205 SvPVX(av) = (char*)ary;
4212 PL_stack_sp = PL_stack_base;
4215 if (PL_stack_sp != PL_stack_base + 1)
4216 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4217 if (!SvNIOKp(*PL_stack_sp))
4218 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4219 result = SvIV(*PL_stack_sp);
4220 while (PL_scopestack_ix > oldscopeix) {
4223 leave_scope(oldsaveix);
4228 sortcv_xsub(pTHXo_ SV *a, SV *b)
4231 I32 oldsaveix = PL_savestack_ix;
4232 I32 oldscopeix = PL_scopestack_ix;
4234 CV *cv=(CV*)PL_sortcop;
4242 (void)(*CvXSUB(cv))(aTHXo_ cv);
4243 if (PL_stack_sp != PL_stack_base + 1)
4244 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4245 if (!SvNIOKp(*PL_stack_sp))
4246 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4247 result = SvIV(*PL_stack_sp);
4248 while (PL_scopestack_ix > oldscopeix) {
4251 leave_scope(oldsaveix);
4257 sv_ncmp(pTHXo_ SV *a, SV *b)
4261 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4265 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4269 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4271 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4273 if (PL_amagic_generation) { \
4274 if (SvAMAGIC(left)||SvAMAGIC(right))\
4275 *svp = amagic_call(left, \
4283 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4286 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4291 I32 i = SvIVX(tmpsv);
4301 return sv_ncmp(aTHXo_ a, b);
4305 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4308 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4313 I32 i = SvIVX(tmpsv);
4323 return sv_i_ncmp(aTHXo_ a, b);
4327 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4330 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4335 I32 i = SvIVX(tmpsv);
4345 return sv_cmp(str1, str2);
4349 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4352 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4357 I32 i = SvIVX(tmpsv);
4367 return sv_cmp_locale(str1, str2);
4371 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4373 SV *datasv = FILTER_DATA(idx);
4374 int filter_has_file = IoLINES(datasv);
4375 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4376 SV *filter_state = (SV *)IoTOP_GV(datasv);
4377 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4380 /* I was having segfault trouble under Linux 2.2.5 after a
4381 parse error occured. (Had to hack around it with a test
4382 for PL_error_count == 0.) Solaris doesn't segfault --
4383 not sure where the trouble is yet. XXX */
4385 if (filter_has_file) {
4386 len = FILTER_READ(idx+1, buf_sv, maxlen);
4389 if (filter_sub && len >= 0) {
4400 PUSHs(sv_2mortal(newSViv(maxlen)));
4402 PUSHs(filter_state);
4405 count = call_sv(filter_sub, G_SCALAR);
4421 IoLINES(datasv) = 0;
4422 if (filter_child_proc) {
4423 SvREFCNT_dec(filter_child_proc);
4424 IoFMT_GV(datasv) = Nullgv;
4427 SvREFCNT_dec(filter_state);
4428 IoTOP_GV(datasv) = Nullgv;
4431 SvREFCNT_dec(filter_sub);
4432 IoBOTTOM_GV(datasv) = Nullgv;
4434 filter_del(run_user_filter);
4443 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4445 return sv_cmp_locale(str1, str2);
4449 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4451 return sv_cmp(str1, str2);
4454 #endif /* PERL_OBJECT */