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 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 djSP; 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 switch (UTF8SKIP(s)) {
565 if ( !((*t++ = *s++) & ~31) )
573 int ch = *t++ = *s++;
576 if ( !((*t++ = *s++) & ~31) )
585 while (*s && isSPACE(*s))
592 item = s = SvPV(sv, len);
594 item_is_utf = FALSE; /* XXX is this correct? */
606 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
607 sv_catpvn(PL_formtarget, item, itemsize);
608 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
609 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
614 /* If the field is marked with ^ and the value is undefined,
617 if ((arg & 512) && !SvOK(sv)) {
625 /* Formats aren't yet marked for locales, so assume "yes". */
627 STORE_NUMERIC_STANDARD_SET_LOCAL();
628 #if defined(USE_LONG_DOUBLE)
630 sprintf(t, "%#*.*" PERL_PRIfldbl,
631 (int) fieldsize, (int) arg & 255, value);
633 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
638 (int) fieldsize, (int) arg & 255, value);
641 (int) fieldsize, value);
644 RESTORE_NUMERIC_STANDARD();
650 /* If the field is marked with ^ and the value is undefined,
653 if ((arg & 512) && !SvOK(sv)) {
661 /* Formats aren't yet marked for locales, so assume "yes". */
663 STORE_NUMERIC_STANDARD_SET_LOCAL();
664 #if defined(USE_LONG_DOUBLE)
666 sprintf(t, "%#0*.*" PERL_PRIfldbl,
667 (int) fieldsize, (int) arg & 255, value);
668 /* is this legal? I don't have long doubles */
670 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
674 sprintf(t, "%#0*.*f",
675 (int) fieldsize, (int) arg & 255, value);
678 (int) fieldsize, value);
681 RESTORE_NUMERIC_STANDARD();
688 while (t-- > linemark && *t == ' ') ;
696 if (arg) { /* repeat until fields exhausted? */
698 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
699 lines += FmLINES(PL_formtarget);
702 if (strnEQ(linemark, linemark - arg, arg))
703 DIE(aTHX_ "Runaway format");
705 FmLINES(PL_formtarget) = lines;
707 RETURNOP(cLISTOP->op_first);
720 while (*s && isSPACE(*s) && s < send)
724 arg = fieldsize - itemsize;
731 if (strnEQ(s," ",3)) {
732 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
743 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
744 FmLINES(PL_formtarget) += lines;
756 if (PL_stack_base + *PL_markstack_ptr == SP) {
758 if (GIMME_V == G_SCALAR)
759 XPUSHs(sv_2mortal(newSViv(0)));
760 RETURNOP(PL_op->op_next->op_next);
762 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
763 pp_pushmark(); /* push dst */
764 pp_pushmark(); /* push src */
765 ENTER; /* enter outer scope */
768 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
770 ENTER; /* enter inner scope */
773 src = PL_stack_base[*PL_markstack_ptr];
778 if (PL_op->op_type == OP_MAPSTART)
779 pp_pushmark(); /* push top */
780 return ((LOGOP*)PL_op->op_next)->op_other;
785 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
791 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
797 /* first, move source pointer to the next item in the source list */
798 ++PL_markstack_ptr[-1];
800 /* if there are new items, push them into the destination list */
802 /* might need to make room back there first */
803 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
804 /* XXX this implementation is very pessimal because the stack
805 * is repeatedly extended for every set of items. Is possible
806 * to do this without any stack extension or copying at all
807 * by maintaining a separate list over which the map iterates
808 * (like foreach does). --gsar */
810 /* everything in the stack after the destination list moves
811 * towards the end the stack by the amount of room needed */
812 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
814 /* items to shift up (accounting for the moved source pointer) */
815 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
817 /* This optimization is by Ben Tilly and it does
818 * things differently from what Sarathy (gsar)
819 * is describing. The downside of this optimization is
820 * that leaves "holes" (uninitialized and hopefully unused areas)
821 * to the Perl stack, but on the other hand this
822 * shouldn't be a problem. If Sarathy's idea gets
823 * implemented, this optimization should become
824 * irrelevant. --jhi */
826 shift = count; /* Avoid shifting too often --Ben Tilly */
831 PL_markstack_ptr[-1] += shift;
832 *PL_markstack_ptr += shift;
836 /* copy the new items down to the destination list */
837 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
839 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
841 LEAVE; /* exit inner scope */
844 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
847 (void)POPMARK; /* pop top */
848 LEAVE; /* exit outer scope */
849 (void)POPMARK; /* pop src */
850 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
851 (void)POPMARK; /* pop dst */
852 SP = PL_stack_base + POPMARK; /* pop original mark */
853 if (gimme == G_SCALAR) {
857 else if (gimme == G_ARRAY)
864 ENTER; /* enter inner scope */
867 /* set $_ to the new source item */
868 src = PL_stack_base[PL_markstack_ptr[-1]];
872 RETURNOP(cLOGOP->op_other);
878 djSP; dMARK; dORIGMARK;
880 SV **myorigmark = ORIGMARK;
886 OP* nextop = PL_op->op_next;
888 bool hasargs = FALSE;
891 if (gimme != G_ARRAY) {
897 SAVEVPTR(PL_sortcop);
898 if (PL_op->op_flags & OPf_STACKED) {
899 if (PL_op->op_flags & OPf_SPECIAL) {
900 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
901 kid = kUNOP->op_first; /* pass rv2gv */
902 kid = kUNOP->op_first; /* pass leave */
903 PL_sortcop = kid->op_next;
904 stash = CopSTASH(PL_curcop);
907 cv = sv_2cv(*++MARK, &stash, &gv, 0);
908 if (cv && SvPOK(cv)) {
910 char *proto = SvPV((SV*)cv, n_a);
911 if (proto && strEQ(proto, "$$")) {
915 if (!(cv && CvROOT(cv))) {
916 if (cv && CvXSUB(cv)) {
920 SV *tmpstr = sv_newmortal();
921 gv_efullname3(tmpstr, gv, Nullch);
922 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
926 DIE(aTHX_ "Undefined subroutine in sort");
931 PL_sortcop = (OP*)cv;
933 PL_sortcop = CvSTART(cv);
934 SAVEVPTR(CvROOT(cv)->op_ppaddr);
935 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
938 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
944 stash = CopSTASH(PL_curcop);
948 while (MARK < SP) { /* This may or may not shift down one here. */
950 if ((*up = *++MARK)) { /* Weed out nulls. */
952 if (!PL_sortcop && !SvPOK(*up)) {
957 (void)sv_2pv(*up, &n_a);
962 max = --up - myorigmark;
967 bool oldcatch = CATCH_GET;
973 PUSHSTACKi(PERLSI_SORT);
974 if (!hasargs && !is_xsub) {
975 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
976 SAVESPTR(PL_firstgv);
977 SAVESPTR(PL_secondgv);
978 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
979 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
980 PL_sortstash = stash;
983 sv_lock((SV *)PL_firstgv);
984 sv_lock((SV *)PL_secondgv);
986 SAVESPTR(GvSV(PL_firstgv));
987 SAVESPTR(GvSV(PL_secondgv));
990 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
991 if (!(PL_op->op_flags & OPf_SPECIAL)) {
992 cx->cx_type = CXt_SUB;
993 cx->blk_gimme = G_SCALAR;
996 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
998 PL_sortcxix = cxstack_ix;
1000 if (hasargs && !is_xsub) {
1001 /* This is mostly copied from pp_entersub */
1002 AV *av = (AV*)PL_curpad[0];
1005 cx->blk_sub.savearray = GvAV(PL_defgv);
1006 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1007 #endif /* USE_THREADS */
1008 cx->blk_sub.oldcurpad = PL_curpad;
1009 cx->blk_sub.argarray = av;
1011 qsortsv((myorigmark+1), max,
1012 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1014 POPBLOCK(cx,PL_curpm);
1015 PL_stack_sp = newsp;
1017 CATCH_SET(oldcatch);
1022 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1023 qsortsv(ORIGMARK+1, max,
1024 (PL_op->op_private & OPpSORT_NUMERIC)
1025 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1026 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1027 : ( overloading ? amagic_ncmp : sv_ncmp))
1028 : ( (PL_op->op_private & OPpLOCALE)
1031 : sv_cmp_locale_static)
1032 : ( overloading ? amagic_cmp : sv_cmp_static)));
1033 if (PL_op->op_private & OPpSORT_REVERSE) {
1034 SV **p = ORIGMARK+1;
1035 SV **q = ORIGMARK+max;
1045 PL_stack_sp = ORIGMARK + max;
1053 if (GIMME == G_ARRAY)
1055 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1056 return cLOGOP->op_other;
1065 if (GIMME == G_ARRAY) {
1066 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1070 SV *targ = PAD_SV(PL_op->op_targ);
1073 if (PL_op->op_private & OPpFLIP_LINENUM) {
1075 flip = PL_last_in_gv
1076 && (gp_io = GvIOp(PL_last_in_gv))
1077 && SvIV(sv) == (IV)IoLINES(gp_io);
1082 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1083 if (PL_op->op_flags & OPf_SPECIAL) {
1091 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1104 if (GIMME == G_ARRAY) {
1110 if (SvGMAGICAL(left))
1112 if (SvGMAGICAL(right))
1115 if (SvNIOKp(left) || !SvPOKp(left) ||
1116 SvNIOKp(right) || !SvPOKp(right) ||
1117 (looks_like_number(left) && *SvPVX(left) != '0' &&
1118 looks_like_number(right) && *SvPVX(right) != '0'))
1120 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1121 DIE(aTHX_ "Range iterator outside integer range");
1132 sv = sv_2mortal(newSViv(i++));
1137 SV *final = sv_mortalcopy(right);
1139 char *tmps = SvPV(final, len);
1141 sv = sv_mortalcopy(left);
1143 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1145 if (strEQ(SvPVX(sv),tmps))
1147 sv = sv_2mortal(newSVsv(sv));
1154 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1156 if ((PL_op->op_private & OPpFLIP_LINENUM)
1157 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1159 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1160 sv_catpv(targ, "E0");
1171 S_dopoptolabel(pTHX_ char *label)
1174 register PERL_CONTEXT *cx;
1176 for (i = cxstack_ix; i >= 0; i--) {
1178 switch (CxTYPE(cx)) {
1180 if (ckWARN(WARN_EXITING))
1181 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1182 PL_op_name[PL_op->op_type]);
1185 if (ckWARN(WARN_EXITING))
1186 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1187 PL_op_name[PL_op->op_type]);
1190 if (ckWARN(WARN_EXITING))
1191 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1192 PL_op_name[PL_op->op_type]);
1195 if (ckWARN(WARN_EXITING))
1196 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1197 PL_op_name[PL_op->op_type]);
1200 if (ckWARN(WARN_EXITING))
1201 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1202 PL_op_name[PL_op->op_type]);
1205 if (!cx->blk_loop.label ||
1206 strNE(label, cx->blk_loop.label) ) {
1207 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1208 (long)i, cx->blk_loop.label));
1211 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1219 Perl_dowantarray(pTHX)
1221 I32 gimme = block_gimme();
1222 return (gimme == G_VOID) ? G_SCALAR : gimme;
1226 Perl_block_gimme(pTHX)
1230 cxix = dopoptosub(cxstack_ix);
1234 switch (cxstack[cxix].blk_gimme) {
1242 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1249 Perl_is_lvalue_sub(pTHX)
1253 cxix = dopoptosub(cxstack_ix);
1254 assert(cxix >= 0); /* We should only be called from inside subs */
1256 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1257 return cxstack[cxix].blk_sub.lval;
1263 S_dopoptosub(pTHX_ I32 startingblock)
1265 return dopoptosub_at(cxstack, startingblock);
1269 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1272 register PERL_CONTEXT *cx;
1273 for (i = startingblock; i >= 0; i--) {
1275 switch (CxTYPE(cx)) {
1281 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1289 S_dopoptoeval(pTHX_ I32 startingblock)
1292 register PERL_CONTEXT *cx;
1293 for (i = startingblock; i >= 0; i--) {
1295 switch (CxTYPE(cx)) {
1299 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1307 S_dopoptoloop(pTHX_ I32 startingblock)
1310 register PERL_CONTEXT *cx;
1311 for (i = startingblock; i >= 0; i--) {
1313 switch (CxTYPE(cx)) {
1315 if (ckWARN(WARN_EXITING))
1316 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1317 PL_op_name[PL_op->op_type]);
1320 if (ckWARN(WARN_EXITING))
1321 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1322 PL_op_name[PL_op->op_type]);
1325 if (ckWARN(WARN_EXITING))
1326 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1327 PL_op_name[PL_op->op_type]);
1330 if (ckWARN(WARN_EXITING))
1331 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1332 PL_op_name[PL_op->op_type]);
1335 if (ckWARN(WARN_EXITING))
1336 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1337 PL_op_name[PL_op->op_type]);
1340 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1348 Perl_dounwind(pTHX_ I32 cxix)
1350 register PERL_CONTEXT *cx;
1353 while (cxstack_ix > cxix) {
1355 cx = &cxstack[cxstack_ix];
1356 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1357 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1358 /* Note: we don't need to restore the base context info till the end. */
1359 switch (CxTYPE(cx)) {
1362 continue; /* not break */
1384 * Closures mentioned at top level of eval cannot be referenced
1385 * again, and their presence indirectly causes a memory leak.
1386 * (Note that the fact that compcv and friends are still set here
1387 * is, AFAIK, an accident.) --Chip
1389 * XXX need to get comppad et al from eval's cv rather than
1390 * relying on the incidental global values.
1393 S_free_closures(pTHX)
1395 SV **svp = AvARRAY(PL_comppad_name);
1397 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1399 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1401 svp[ix] = &PL_sv_undef;
1405 SvREFCNT_dec(CvOUTSIDE(sv));
1406 CvOUTSIDE(sv) = Nullcv;
1419 Perl_qerror(pTHX_ SV *err)
1422 sv_catsv(ERRSV, err);
1424 sv_catsv(PL_errors, err);
1426 Perl_warn(aTHX_ "%"SVf, err);
1431 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1436 register PERL_CONTEXT *cx;
1441 if (PL_in_eval & EVAL_KEEPERR) {
1442 static char prefix[] = "\t(in cleanup) ";
1447 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1450 if (*e != *message || strNE(e,message))
1454 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1455 sv_catpvn(err, prefix, sizeof(prefix)-1);
1456 sv_catpvn(err, message, msglen);
1457 if (ckWARN(WARN_MISC)) {
1458 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1459 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1464 sv_setpvn(ERRSV, message, msglen);
1465 if (PL_hints & HINT_UTF8)
1472 message = SvPVx(ERRSV, msglen);
1474 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1475 && PL_curstackinfo->si_prev)
1484 if (cxix < cxstack_ix)
1487 POPBLOCK(cx,PL_curpm);
1488 if (CxTYPE(cx) != CXt_EVAL) {
1489 PerlIO_write(Perl_error_log, "panic: die ", 11);
1490 PerlIO_write(Perl_error_log, message, msglen);
1495 if (gimme == G_SCALAR)
1496 *++newsp = &PL_sv_undef;
1497 PL_stack_sp = newsp;
1501 /* LEAVE could clobber PL_curcop (see save_re_context())
1502 * XXX it might be better to find a way to avoid messing with
1503 * PL_curcop in save_re_context() instead, but this is a more
1504 * minimal fix --GSAR */
1505 PL_curcop = cx->blk_oldcop;
1507 if (optype == OP_REQUIRE) {
1508 char* msg = SvPVx(ERRSV, n_a);
1509 DIE(aTHX_ "%sCompilation failed in require",
1510 *msg ? msg : "Unknown error\n");
1512 return pop_return();
1516 message = SvPVx(ERRSV, msglen);
1519 /* SFIO can really mess with your errno */
1522 PerlIO *serr = Perl_error_log;
1524 PerlIO_write(serr, message, msglen);
1525 (void)PerlIO_flush(serr);
1538 if (SvTRUE(left) != SvTRUE(right))
1550 RETURNOP(cLOGOP->op_other);
1559 RETURNOP(cLOGOP->op_other);
1565 register I32 cxix = dopoptosub(cxstack_ix);
1566 register PERL_CONTEXT *cx;
1567 register PERL_CONTEXT *ccstack = cxstack;
1568 PERL_SI *top_si = PL_curstackinfo;
1579 /* we may be in a higher stacklevel, so dig down deeper */
1580 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1581 top_si = top_si->si_prev;
1582 ccstack = top_si->si_cxstack;
1583 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1586 if (GIMME != G_ARRAY)
1590 if (PL_DBsub && cxix >= 0 &&
1591 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1595 cxix = dopoptosub_at(ccstack, cxix - 1);
1598 cx = &ccstack[cxix];
1599 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1600 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1601 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1602 field below is defined for any cx. */
1603 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1604 cx = &ccstack[dbcxix];
1607 stashname = CopSTASHPV(cx->blk_oldcop);
1608 if (GIMME != G_ARRAY) {
1610 PUSHs(&PL_sv_undef);
1613 sv_setpv(TARG, stashname);
1620 PUSHs(&PL_sv_undef);
1622 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1623 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1624 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1627 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1628 /* So is ccstack[dbcxix]. */
1630 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1631 PUSHs(sv_2mortal(sv));
1632 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1635 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1636 PUSHs(sv_2mortal(newSViv(0)));
1638 gimme = (I32)cx->blk_gimme;
1639 if (gimme == G_VOID)
1640 PUSHs(&PL_sv_undef);
1642 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1643 if (CxTYPE(cx) == CXt_EVAL) {
1645 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1646 PUSHs(cx->blk_eval.cur_text);
1650 else if (cx->blk_eval.old_namesv) {
1651 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1654 /* eval BLOCK (try blocks have old_namesv == 0) */
1656 PUSHs(&PL_sv_undef);
1657 PUSHs(&PL_sv_undef);
1661 PUSHs(&PL_sv_undef);
1662 PUSHs(&PL_sv_undef);
1664 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1665 && CopSTASH_eq(PL_curcop, PL_debstash))
1667 AV *ary = cx->blk_sub.argarray;
1668 int off = AvARRAY(ary) - AvALLOC(ary);
1672 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1675 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1678 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1679 av_extend(PL_dbargs, AvFILLp(ary) + off);
1680 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1681 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1683 /* XXX only hints propagated via op_private are currently
1684 * visible (others are not easily accessible, since they
1685 * use the global PL_hints) */
1686 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1687 HINT_PRIVATE_MASK)));
1690 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1692 if (old_warnings == pWARN_NONE ||
1693 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1694 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1695 else if (old_warnings == pWARN_ALL ||
1696 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1697 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1699 mask = newSVsv(old_warnings);
1700 PUSHs(sv_2mortal(mask));
1715 sv_reset(tmps, CopSTASH(PL_curcop));
1727 PL_curcop = (COP*)PL_op;
1728 TAINT_NOT; /* Each statement is presumed innocent */
1729 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1732 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1736 register PERL_CONTEXT *cx;
1737 I32 gimme = G_ARRAY;
1744 DIE(aTHX_ "No DB::DB routine defined");
1746 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1758 push_return(PL_op->op_next);
1759 PUSHBLOCK(cx, CXt_SUB, SP);
1762 (void)SvREFCNT_inc(cv);
1763 SAVEVPTR(PL_curpad);
1764 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1765 RETURNOP(CvSTART(cv));
1779 register PERL_CONTEXT *cx;
1780 I32 gimme = GIMME_V;
1782 U32 cxtype = CXt_LOOP;
1791 if (PL_op->op_flags & OPf_SPECIAL) {
1792 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1793 SAVEGENERICSV(*svp);
1797 #endif /* USE_THREADS */
1798 if (PL_op->op_targ) {
1799 #ifndef USE_ITHREADS
1800 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1803 SAVEPADSV(PL_op->op_targ);
1804 iterdata = (void*)PL_op->op_targ;
1805 cxtype |= CXp_PADVAR;
1810 svp = &GvSV(gv); /* symbol table variable */
1811 SAVEGENERICSV(*svp);
1814 iterdata = (void*)gv;
1820 PUSHBLOCK(cx, cxtype, SP);
1822 PUSHLOOP(cx, iterdata, MARK);
1824 PUSHLOOP(cx, svp, MARK);
1826 if (PL_op->op_flags & OPf_STACKED) {
1827 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1828 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1830 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1831 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1832 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1833 looks_like_number((SV*)cx->blk_loop.iterary) &&
1834 *SvPVX(cx->blk_loop.iterary) != '0'))
1836 if (SvNV(sv) < IV_MIN ||
1837 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1838 DIE(aTHX_ "Range iterator outside integer range");
1839 cx->blk_loop.iterix = SvIV(sv);
1840 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1843 cx->blk_loop.iterlval = newSVsv(sv);
1847 cx->blk_loop.iterary = PL_curstack;
1848 AvFILLp(PL_curstack) = SP - PL_stack_base;
1849 cx->blk_loop.iterix = MARK - PL_stack_base;
1858 register PERL_CONTEXT *cx;
1859 I32 gimme = GIMME_V;
1865 PUSHBLOCK(cx, CXt_LOOP, SP);
1866 PUSHLOOP(cx, 0, SP);
1874 register PERL_CONTEXT *cx;
1882 newsp = PL_stack_base + cx->blk_loop.resetsp;
1885 if (gimme == G_VOID)
1887 else if (gimme == G_SCALAR) {
1889 *++newsp = sv_mortalcopy(*SP);
1891 *++newsp = &PL_sv_undef;
1895 *++newsp = sv_mortalcopy(*++mark);
1896 TAINT_NOT; /* Each item is independent */
1902 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1903 PL_curpm = newpm; /* ... and pop $1 et al */
1915 register PERL_CONTEXT *cx;
1916 bool popsub2 = FALSE;
1917 bool clear_errsv = FALSE;
1924 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1925 if (cxstack_ix == PL_sortcxix
1926 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1928 if (cxstack_ix > PL_sortcxix)
1929 dounwind(PL_sortcxix);
1930 AvARRAY(PL_curstack)[1] = *SP;
1931 PL_stack_sp = PL_stack_base + 1;
1936 cxix = dopoptosub(cxstack_ix);
1938 DIE(aTHX_ "Can't return outside a subroutine");
1939 if (cxix < cxstack_ix)
1943 switch (CxTYPE(cx)) {
1948 if (!(PL_in_eval & EVAL_KEEPERR))
1953 if (AvFILLp(PL_comppad_name) >= 0)
1956 if (optype == OP_REQUIRE &&
1957 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1959 /* Unassume the success we assumed earlier. */
1960 SV *nsv = cx->blk_eval.old_namesv;
1961 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1962 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1969 DIE(aTHX_ "panic: return");
1973 if (gimme == G_SCALAR) {
1976 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1978 *++newsp = SvREFCNT_inc(*SP);
1983 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1985 *++newsp = sv_mortalcopy(sv);
1990 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1993 *++newsp = sv_mortalcopy(*SP);
1996 *++newsp = &PL_sv_undef;
1998 else if (gimme == G_ARRAY) {
1999 while (++MARK <= SP) {
2000 *++newsp = (popsub2 && SvTEMP(*MARK))
2001 ? *MARK : sv_mortalcopy(*MARK);
2002 TAINT_NOT; /* Each item is independent */
2005 PL_stack_sp = newsp;
2007 /* Stack values are safe: */
2009 POPSUB(cx,sv); /* release CV and @_ ... */
2013 PL_curpm = newpm; /* ... and pop $1 et al */
2019 return pop_return();
2026 register PERL_CONTEXT *cx;
2036 if (PL_op->op_flags & OPf_SPECIAL) {
2037 cxix = dopoptoloop(cxstack_ix);
2039 DIE(aTHX_ "Can't \"last\" outside a loop block");
2042 cxix = dopoptolabel(cPVOP->op_pv);
2044 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2046 if (cxix < cxstack_ix)
2051 switch (CxTYPE(cx)) {
2054 newsp = PL_stack_base + cx->blk_loop.resetsp;
2055 nextop = cx->blk_loop.last_op->op_next;
2059 nextop = pop_return();
2063 nextop = pop_return();
2067 nextop = pop_return();
2070 DIE(aTHX_ "panic: last");
2074 if (gimme == G_SCALAR) {
2076 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2077 ? *SP : sv_mortalcopy(*SP);
2079 *++newsp = &PL_sv_undef;
2081 else if (gimme == G_ARRAY) {
2082 while (++MARK <= SP) {
2083 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2084 ? *MARK : sv_mortalcopy(*MARK);
2085 TAINT_NOT; /* Each item is independent */
2091 /* Stack values are safe: */
2094 POPLOOP(cx); /* release loop vars ... */
2098 POPSUB(cx,sv); /* release CV and @_ ... */
2101 PL_curpm = newpm; /* ... and pop $1 et al */
2111 register PERL_CONTEXT *cx;
2114 if (PL_op->op_flags & OPf_SPECIAL) {
2115 cxix = dopoptoloop(cxstack_ix);
2117 DIE(aTHX_ "Can't \"next\" outside a loop block");
2120 cxix = dopoptolabel(cPVOP->op_pv);
2122 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2124 if (cxix < cxstack_ix)
2127 /* clear off anything above the scope we're re-entering, but
2128 * save the rest until after a possible continue block */
2129 inner = PL_scopestack_ix;
2131 if (PL_scopestack_ix < inner)
2132 leave_scope(PL_scopestack[PL_scopestack_ix]);
2133 return cx->blk_loop.next_op;
2139 register PERL_CONTEXT *cx;
2142 if (PL_op->op_flags & OPf_SPECIAL) {
2143 cxix = dopoptoloop(cxstack_ix);
2145 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2148 cxix = dopoptolabel(cPVOP->op_pv);
2150 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2152 if (cxix < cxstack_ix)
2156 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2157 LEAVE_SCOPE(oldsave);
2158 return cx->blk_loop.redo_op;
2162 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2166 static char too_deep[] = "Target of goto is too deeply nested";
2169 Perl_croak(aTHX_ too_deep);
2170 if (o->op_type == OP_LEAVE ||
2171 o->op_type == OP_SCOPE ||
2172 o->op_type == OP_LEAVELOOP ||
2173 o->op_type == OP_LEAVETRY)
2175 *ops++ = cUNOPo->op_first;
2177 Perl_croak(aTHX_ too_deep);
2180 if (o->op_flags & OPf_KIDS) {
2181 /* First try all the kids at this level, since that's likeliest. */
2182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2183 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2184 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2187 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2188 if (kid == PL_lastgotoprobe)
2190 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2192 (ops[-1]->op_type != OP_NEXTSTATE &&
2193 ops[-1]->op_type != OP_DBSTATE)))
2195 if ((o = dofindlabel(kid, label, ops, oplimit)))
2214 register PERL_CONTEXT *cx;
2215 #define GOTO_DEPTH 64
2216 OP *enterops[GOTO_DEPTH];
2218 int do_dump = (PL_op->op_type == OP_DUMP);
2219 static char must_have_label[] = "goto must have label";
2222 if (PL_op->op_flags & OPf_STACKED) {
2226 /* This egregious kludge implements goto &subroutine */
2227 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2229 register PERL_CONTEXT *cx;
2230 CV* cv = (CV*)SvRV(sv);
2236 if (!CvROOT(cv) && !CvXSUB(cv)) {
2241 /* autoloaded stub? */
2242 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2244 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2245 GvNAMELEN(gv), FALSE);
2246 if (autogv && (cv = GvCV(autogv)))
2248 tmpstr = sv_newmortal();
2249 gv_efullname3(tmpstr, gv, Nullch);
2250 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2252 DIE(aTHX_ "Goto undefined subroutine");
2255 /* First do some returnish stuff. */
2256 cxix = dopoptosub(cxstack_ix);
2258 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2259 if (cxix < cxstack_ix)
2262 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2263 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2265 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2266 /* put @_ back onto stack */
2267 AV* av = cx->blk_sub.argarray;
2269 items = AvFILLp(av) + 1;
2271 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2272 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2273 PL_stack_sp += items;
2275 SvREFCNT_dec(GvAV(PL_defgv));
2276 GvAV(PL_defgv) = cx->blk_sub.savearray;
2277 #endif /* USE_THREADS */
2278 /* abandon @_ if it got reified */
2280 (void)sv_2mortal((SV*)av); /* delay until return */
2282 av_extend(av, items-1);
2283 AvFLAGS(av) = AVf_REIFY;
2284 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2287 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2290 av = (AV*)PL_curpad[0];
2292 av = GvAV(PL_defgv);
2294 items = AvFILLp(av) + 1;
2296 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2297 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2298 PL_stack_sp += items;
2300 if (CxTYPE(cx) == CXt_SUB &&
2301 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2302 SvREFCNT_dec(cx->blk_sub.cv);
2303 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2304 LEAVE_SCOPE(oldsave);
2306 /* Now do some callish stuff. */
2309 #ifdef PERL_XSUB_OLDSTYLE
2310 if (CvOLDSTYLE(cv)) {
2311 I32 (*fp3)(int,int,int);
2316 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2317 items = (*fp3)(CvXSUBANY(cv).any_i32,
2318 mark - PL_stack_base + 1,
2320 SP = PL_stack_base + items;
2323 #endif /* PERL_XSUB_OLDSTYLE */
2328 PL_stack_sp--; /* There is no cv arg. */
2329 /* Push a mark for the start of arglist */
2331 (void)(*CvXSUB(cv))(aTHXo_ cv);
2332 /* Pop the current context like a decent sub should */
2333 POPBLOCK(cx, PL_curpm);
2334 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2337 return pop_return();
2340 AV* padlist = CvPADLIST(cv);
2341 SV** svp = AvARRAY(padlist);
2342 if (CxTYPE(cx) == CXt_EVAL) {
2343 PL_in_eval = cx->blk_eval.old_in_eval;
2344 PL_eval_root = cx->blk_eval.old_eval_root;
2345 cx->cx_type = CXt_SUB;
2346 cx->blk_sub.hasargs = 0;
2348 cx->blk_sub.cv = cv;
2349 cx->blk_sub.olddepth = CvDEPTH(cv);
2351 if (CvDEPTH(cv) < 2)
2352 (void)SvREFCNT_inc(cv);
2353 else { /* save temporaries on recursion? */
2354 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2355 sub_crush_depth(cv);
2356 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2357 AV *newpad = newAV();
2358 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2359 I32 ix = AvFILLp((AV*)svp[1]);
2360 I32 names_fill = AvFILLp((AV*)svp[0]);
2361 svp = AvARRAY(svp[0]);
2362 for ( ;ix > 0; ix--) {
2363 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2364 char *name = SvPVX(svp[ix]);
2365 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2368 /* outer lexical or anon code */
2369 av_store(newpad, ix,
2370 SvREFCNT_inc(oldpad[ix]) );
2372 else { /* our own lexical */
2374 av_store(newpad, ix, sv = (SV*)newAV());
2375 else if (*name == '%')
2376 av_store(newpad, ix, sv = (SV*)newHV());
2378 av_store(newpad, ix, sv = NEWSV(0,0));
2382 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2383 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2386 av_store(newpad, ix, sv = NEWSV(0,0));
2390 if (cx->blk_sub.hasargs) {
2393 av_store(newpad, 0, (SV*)av);
2394 AvFLAGS(av) = AVf_REIFY;
2396 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2397 AvFILLp(padlist) = CvDEPTH(cv);
2398 svp = AvARRAY(padlist);
2402 if (!cx->blk_sub.hasargs) {
2403 AV* av = (AV*)PL_curpad[0];
2405 items = AvFILLp(av) + 1;
2407 /* Mark is at the end of the stack. */
2409 Copy(AvARRAY(av), SP + 1, items, SV*);
2414 #endif /* USE_THREADS */
2415 SAVEVPTR(PL_curpad);
2416 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2418 if (cx->blk_sub.hasargs)
2419 #endif /* USE_THREADS */
2421 AV* av = (AV*)PL_curpad[0];
2425 cx->blk_sub.savearray = GvAV(PL_defgv);
2426 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2427 #endif /* USE_THREADS */
2428 cx->blk_sub.oldcurpad = PL_curpad;
2429 cx->blk_sub.argarray = av;
2432 if (items >= AvMAX(av) + 1) {
2434 if (AvARRAY(av) != ary) {
2435 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2436 SvPVX(av) = (char*)ary;
2438 if (items >= AvMAX(av) + 1) {
2439 AvMAX(av) = items - 1;
2440 Renew(ary,items+1,SV*);
2442 SvPVX(av) = (char*)ary;
2445 Copy(mark,AvARRAY(av),items,SV*);
2446 AvFILLp(av) = items - 1;
2447 assert(!AvREAL(av));
2454 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2456 * We do not care about using sv to call CV;
2457 * it's for informational purposes only.
2459 SV *sv = GvSV(PL_DBsub);
2462 if (PERLDB_SUB_NN) {
2463 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2466 gv_efullname3(sv, CvGV(cv), Nullch);
2469 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2470 PUSHMARK( PL_stack_sp );
2471 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2475 RETURNOP(CvSTART(cv));
2479 label = SvPV(sv,n_a);
2480 if (!(do_dump || *label))
2481 DIE(aTHX_ must_have_label);
2484 else if (PL_op->op_flags & OPf_SPECIAL) {
2486 DIE(aTHX_ must_have_label);
2489 label = cPVOP->op_pv;
2491 if (label && *label) {
2496 PL_lastgotoprobe = 0;
2498 for (ix = cxstack_ix; ix >= 0; ix--) {
2500 switch (CxTYPE(cx)) {
2502 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2505 gotoprobe = cx->blk_oldcop->op_sibling;
2511 gotoprobe = cx->blk_oldcop->op_sibling;
2513 gotoprobe = PL_main_root;
2516 if (CvDEPTH(cx->blk_sub.cv)) {
2517 gotoprobe = CvROOT(cx->blk_sub.cv);
2523 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2526 DIE(aTHX_ "panic: goto");
2527 gotoprobe = PL_main_root;
2531 retop = dofindlabel(gotoprobe, label,
2532 enterops, enterops + GOTO_DEPTH);
2536 PL_lastgotoprobe = gotoprobe;
2539 DIE(aTHX_ "Can't find label %s", label);
2541 /* pop unwanted frames */
2543 if (ix < cxstack_ix) {
2550 oldsave = PL_scopestack[PL_scopestack_ix];
2551 LEAVE_SCOPE(oldsave);
2554 /* push wanted frames */
2556 if (*enterops && enterops[1]) {
2558 for (ix = 1; enterops[ix]; ix++) {
2559 PL_op = enterops[ix];
2560 /* Eventually we may want to stack the needed arguments
2561 * for each op. For now, we punt on the hard ones. */
2562 if (PL_op->op_type == OP_ENTERITER)
2563 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2564 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2572 if (!retop) retop = PL_main_start;
2574 PL_restartop = retop;
2575 PL_do_undump = TRUE;
2579 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2580 PL_do_undump = FALSE;
2596 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2600 PL_exit_flags |= PERL_EXIT_EXPECTED;
2602 PUSHs(&PL_sv_undef);
2610 NV value = SvNVx(GvSV(cCOP->cop_gv));
2611 register I32 match = I_32(value);
2614 if (((NV)match) > value)
2615 --match; /* was fractional--truncate other way */
2617 match -= cCOP->uop.scop.scop_offset;
2620 else if (match > cCOP->uop.scop.scop_max)
2621 match = cCOP->uop.scop.scop_max;
2622 PL_op = cCOP->uop.scop.scop_next[match];
2632 PL_op = PL_op->op_next; /* can't assume anything */
2635 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2636 match -= cCOP->uop.scop.scop_offset;
2639 else if (match > cCOP->uop.scop.scop_max)
2640 match = cCOP->uop.scop.scop_max;
2641 PL_op = cCOP->uop.scop.scop_next[match];
2650 S_save_lines(pTHX_ AV *array, SV *sv)
2652 register char *s = SvPVX(sv);
2653 register char *send = SvPVX(sv) + SvCUR(sv);
2655 register I32 line = 1;
2657 while (s && s < send) {
2658 SV *tmpstr = NEWSV(85,0);
2660 sv_upgrade(tmpstr, SVt_PVMG);
2661 t = strchr(s, '\n');
2667 sv_setpvn(tmpstr, s, t - s);
2668 av_store(array, line++, tmpstr);
2673 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2675 S_docatch_body(pTHX_ va_list args)
2677 return docatch_body();
2682 S_docatch_body(pTHX)
2689 S_docatch(pTHX_ OP *o)
2693 volatile PERL_SI *cursi = PL_curstackinfo;
2697 assert(CATCH_GET == TRUE);
2700 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2702 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2708 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2714 if (PL_restartop && cursi == PL_curstackinfo) {
2715 PL_op = PL_restartop;
2732 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2733 /* sv Text to convert to OP tree. */
2734 /* startop op_free() this to undo. */
2735 /* code Short string id of the caller. */
2737 dSP; /* Make POPBLOCK work. */
2740 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2744 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2745 char *tmpbuf = tbuf;
2751 /* switch to eval mode */
2753 if (PL_curcop == &PL_compiling) {
2754 SAVECOPSTASH_FREE(&PL_compiling);
2755 CopSTASH_set(&PL_compiling, PL_curstash);
2757 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2758 SV *sv = sv_newmortal();
2759 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2760 code, (unsigned long)++PL_evalseq,
2761 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2765 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2766 SAVECOPFILE_FREE(&PL_compiling);
2767 CopFILE_set(&PL_compiling, tmpbuf+2);
2768 SAVECOPLINE(&PL_compiling);
2769 CopLINE_set(&PL_compiling, 1);
2770 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2771 deleting the eval's FILEGV from the stash before gv_check() runs
2772 (i.e. before run-time proper). To work around the coredump that
2773 ensues, we always turn GvMULTI_on for any globals that were
2774 introduced within evals. See force_ident(). GSAR 96-10-12 */
2775 safestr = savepv(tmpbuf);
2776 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2778 #ifdef OP_IN_REGISTER
2783 PL_hints &= HINT_UTF8;
2786 PL_op->op_type = OP_ENTEREVAL;
2787 PL_op->op_flags = 0; /* Avoid uninit warning. */
2788 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2789 PUSHEVAL(cx, 0, Nullgv);
2790 rop = doeval(G_SCALAR, startop);
2791 POPBLOCK(cx,PL_curpm);
2794 (*startop)->op_type = OP_NULL;
2795 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2797 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2799 if (PL_curcop == &PL_compiling)
2800 PL_compiling.op_private = PL_hints;
2801 #ifdef OP_IN_REGISTER
2807 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2809 S_doeval(pTHX_ int gimme, OP** startop)
2817 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2818 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2823 /* set up a scratch pad */
2826 SAVEVPTR(PL_curpad);
2827 SAVESPTR(PL_comppad);
2828 SAVESPTR(PL_comppad_name);
2829 SAVEI32(PL_comppad_name_fill);
2830 SAVEI32(PL_min_intro_pending);
2831 SAVEI32(PL_max_intro_pending);
2834 for (i = cxstack_ix - 1; i >= 0; i--) {
2835 PERL_CONTEXT *cx = &cxstack[i];
2836 if (CxTYPE(cx) == CXt_EVAL)
2838 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2839 caller = cx->blk_sub.cv;
2844 SAVESPTR(PL_compcv);
2845 PL_compcv = (CV*)NEWSV(1104,0);
2846 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2847 CvEVAL_on(PL_compcv);
2849 CvOWNER(PL_compcv) = 0;
2850 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2851 MUTEX_INIT(CvMUTEXP(PL_compcv));
2852 #endif /* USE_THREADS */
2854 PL_comppad = newAV();
2855 av_push(PL_comppad, Nullsv);
2856 PL_curpad = AvARRAY(PL_comppad);
2857 PL_comppad_name = newAV();
2858 PL_comppad_name_fill = 0;
2859 PL_min_intro_pending = 0;
2862 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2863 PL_curpad[0] = (SV*)newAV();
2864 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2865 #endif /* USE_THREADS */
2867 comppadlist = newAV();
2868 AvREAL_off(comppadlist);
2869 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2870 av_store(comppadlist, 1, (SV*)PL_comppad);
2871 CvPADLIST(PL_compcv) = comppadlist;
2874 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2876 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2879 SAVEFREESV(PL_compcv);
2881 /* make sure we compile in the right package */
2883 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2884 SAVESPTR(PL_curstash);
2885 PL_curstash = CopSTASH(PL_curcop);
2887 SAVESPTR(PL_beginav);
2888 PL_beginav = newAV();
2889 SAVEFREESV(PL_beginav);
2890 SAVEI32(PL_error_count);
2892 /* try to compile it */
2894 PL_eval_root = Nullop;
2896 PL_curcop = &PL_compiling;
2897 PL_curcop->cop_arybase = 0;
2898 SvREFCNT_dec(PL_rs);
2899 PL_rs = newSVpvn("\n", 1);
2900 if (saveop && saveop->op_flags & OPf_SPECIAL)
2901 PL_in_eval |= EVAL_KEEPERR;
2904 if (yyparse() || PL_error_count || !PL_eval_root) {
2908 I32 optype = 0; /* Might be reset by POPEVAL. */
2913 op_free(PL_eval_root);
2914 PL_eval_root = Nullop;
2916 SP = PL_stack_base + POPMARK; /* pop original mark */
2918 POPBLOCK(cx,PL_curpm);
2924 if (optype == OP_REQUIRE) {
2925 char* msg = SvPVx(ERRSV, n_a);
2926 DIE(aTHX_ "%sCompilation failed in require",
2927 *msg ? msg : "Unknown error\n");
2930 char* msg = SvPVx(ERRSV, n_a);
2932 POPBLOCK(cx,PL_curpm);
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
2937 SvREFCNT_dec(PL_rs);
2938 PL_rs = SvREFCNT_inc(PL_nrs);
2940 MUTEX_LOCK(&PL_eval_mutex);
2942 COND_SIGNAL(&PL_eval_cond);
2943 MUTEX_UNLOCK(&PL_eval_mutex);
2944 #endif /* USE_THREADS */
2947 SvREFCNT_dec(PL_rs);
2948 PL_rs = SvREFCNT_inc(PL_nrs);
2949 CopLINE_set(&PL_compiling, 0);
2951 *startop = PL_eval_root;
2952 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2953 CvOUTSIDE(PL_compcv) = Nullcv;
2955 SAVEFREEOP(PL_eval_root);
2957 scalarvoid(PL_eval_root);
2958 else if (gimme & G_ARRAY)
2961 scalar(PL_eval_root);
2963 DEBUG_x(dump_eval());
2965 /* Register with debugger: */
2966 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2967 CV *cv = get_cv("DB::postponed", FALSE);
2971 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2973 call_sv((SV*)cv, G_DISCARD);
2977 /* compiled okay, so do it */
2979 CvDEPTH(PL_compcv) = 1;
2980 SP = PL_stack_base + POPMARK; /* pop original mark */
2981 PL_op = saveop; /* The caller may need it. */
2982 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2984 MUTEX_LOCK(&PL_eval_mutex);
2986 COND_SIGNAL(&PL_eval_cond);
2987 MUTEX_UNLOCK(&PL_eval_mutex);
2988 #endif /* USE_THREADS */
2990 RETURNOP(PL_eval_start);
2994 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2996 STRLEN namelen = strlen(name);
2999 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3000 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3001 char *pmc = SvPV_nolen(pmcsv);
3004 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3005 fp = PerlIO_open(name, mode);
3008 if (PerlLIO_stat(name, &pmstat) < 0 ||
3009 pmstat.st_mtime < pmcstat.st_mtime)
3011 fp = PerlIO_open(pmc, mode);
3014 fp = PerlIO_open(name, mode);
3017 SvREFCNT_dec(pmcsv);
3020 fp = PerlIO_open(name, mode);
3028 register PERL_CONTEXT *cx;
3033 SV *namesv = Nullsv;
3035 I32 gimme = G_SCALAR;
3036 PerlIO *tryrsfp = 0;
3038 int filter_has_file = 0;
3039 GV *filter_child_proc = 0;
3040 SV *filter_state = 0;
3045 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3046 UV rev = 0, ver = 0, sver = 0;
3048 U8 *s = (U8*)SvPVX(sv);
3049 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3051 rev = utf8_to_uv(s, end - s, &len, 0);
3054 ver = utf8_to_uv(s, end - s, &len, 0);
3057 sver = utf8_to_uv(s, end - s, &len, 0);
3060 if (PERL_REVISION < rev
3061 || (PERL_REVISION == rev
3062 && (PERL_VERSION < ver
3063 || (PERL_VERSION == ver
3064 && PERL_SUBVERSION < sver))))
3066 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3067 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3068 PERL_VERSION, PERL_SUBVERSION);
3072 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3073 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3074 + ((NV)PERL_SUBVERSION/(NV)1000000)
3075 + 0.00000099 < SvNV(sv))
3079 NV nver = (nrev - rev) * 1000;
3080 UV ver = (UV)(nver + 0.0009);
3081 NV nsver = (nver - ver) * 1000;
3082 UV sver = (UV)(nsver + 0.0009);
3084 /* help out with the "use 5.6" confusion */
3085 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3086 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3087 "this is only v%d.%d.%d, stopped"
3088 " (did you mean v%"UVuf".%"UVuf".0?)",
3089 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3090 PERL_SUBVERSION, rev, ver/100);
3093 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3094 "this is only v%d.%d.%d, stopped",
3095 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3102 name = SvPV(sv, len);
3103 if (!(name && len > 0 && *name))
3104 DIE(aTHX_ "Null filename used");
3105 TAINT_PROPER("require");
3106 if (PL_op->op_type == OP_REQUIRE &&
3107 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3108 *svp != &PL_sv_undef)
3111 /* prepare to compile file */
3113 #ifdef MACOS_TRADITIONAL
3114 if (PERL_FILE_IS_ABSOLUTE(name)
3115 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3118 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3119 /* We consider paths of the form :a:b ambiguous and interpret them first
3120 as global then as local
3122 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3128 if (PERL_FILE_IS_ABSOLUTE(name)
3129 || (*name == '.' && (name[1] == '/' ||
3130 (name[1] == '.' && name[2] == '/'))))
3133 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3137 AV *ar = GvAVn(PL_incgv);
3141 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3144 namesv = NEWSV(806, 0);
3145 for (i = 0; i <= AvFILL(ar); i++) {
3146 SV *dirsv = *av_fetch(ar, i, TRUE);
3152 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3153 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3156 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3157 PTR2UV(SvANY(loader)), name);
3158 tryname = SvPVX(namesv);
3169 count = call_sv(loader, G_ARRAY);
3179 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3183 if (SvTYPE(arg) == SVt_PVGV) {
3184 IO *io = GvIO((GV *)arg);
3189 tryrsfp = IoIFP(io);
3190 if (IoTYPE(io) == IoTYPE_PIPE) {
3191 /* reading from a child process doesn't
3192 nest -- when returning from reading
3193 the inner module, the outer one is
3194 unreadable (closed?) I've tried to
3195 save the gv to manage the lifespan of
3196 the pipe, but this didn't help. XXX */
3197 filter_child_proc = (GV *)arg;
3198 (void)SvREFCNT_inc(filter_child_proc);
3201 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3202 PerlIO_close(IoOFP(io));
3214 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3216 (void)SvREFCNT_inc(filter_sub);
3219 filter_state = SP[i];
3220 (void)SvREFCNT_inc(filter_state);
3224 tryrsfp = PerlIO_open("/dev/null",
3238 filter_has_file = 0;
3239 if (filter_child_proc) {
3240 SvREFCNT_dec(filter_child_proc);
3241 filter_child_proc = 0;
3244 SvREFCNT_dec(filter_state);
3248 SvREFCNT_dec(filter_sub);
3253 char *dir = SvPVx(dirsv, n_a);
3254 #ifdef MACOS_TRADITIONAL
3256 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3260 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3262 sv_setpv(namesv, unixdir);
3263 sv_catpv(namesv, unixname);
3265 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3268 TAINT_PROPER("require");
3269 tryname = SvPVX(namesv);
3270 #ifdef MACOS_TRADITIONAL
3272 /* Convert slashes in the name part, but not the directory part, to colons */
3274 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3278 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3280 if (tryname[0] == '.' && tryname[1] == '/')
3288 SAVECOPFILE_FREE(&PL_compiling);
3289 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3290 SvREFCNT_dec(namesv);
3292 if (PL_op->op_type == OP_REQUIRE) {
3293 char *msgstr = name;
3294 if (namesv) { /* did we lookup @INC? */
3295 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3296 SV *dirmsgsv = NEWSV(0, 0);
3297 AV *ar = GvAVn(PL_incgv);
3299 sv_catpvn(msg, " in @INC", 8);
3300 if (instr(SvPVX(msg), ".h "))
3301 sv_catpv(msg, " (change .h to .ph maybe?)");
3302 if (instr(SvPVX(msg), ".ph "))
3303 sv_catpv(msg, " (did you run h2ph?)");
3304 sv_catpv(msg, " (@INC contains:");
3305 for (i = 0; i <= AvFILL(ar); i++) {
3306 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3307 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3308 sv_catsv(msg, dirmsgsv);
3310 sv_catpvn(msg, ")", 1);
3311 SvREFCNT_dec(dirmsgsv);
3312 msgstr = SvPV_nolen(msg);
3314 DIE(aTHX_ "Can't locate %s", msgstr);
3320 SETERRNO(0, SS$_NORMAL);
3322 /* Assume success here to prevent recursive requirement. */
3323 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3324 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3328 lex_start(sv_2mortal(newSVpvn("",0)));
3329 SAVEGENERICSV(PL_rsfp_filters);
3330 PL_rsfp_filters = Nullav;
3335 SAVESPTR(PL_compiling.cop_warnings);
3336 if (PL_dowarn & G_WARN_ALL_ON)
3337 PL_compiling.cop_warnings = pWARN_ALL ;
3338 else if (PL_dowarn & G_WARN_ALL_OFF)
3339 PL_compiling.cop_warnings = pWARN_NONE ;
3341 PL_compiling.cop_warnings = pWARN_STD ;
3342 SAVESPTR(PL_compiling.cop_io);
3343 PL_compiling.cop_io = Nullsv;
3345 if (filter_sub || filter_child_proc) {
3346 SV *datasv = filter_add(run_user_filter, Nullsv);
3347 IoLINES(datasv) = filter_has_file;
3348 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3349 IoTOP_GV(datasv) = (GV *)filter_state;
3350 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3353 /* switch to eval mode */
3354 push_return(PL_op->op_next);
3355 PUSHBLOCK(cx, CXt_EVAL, SP);
3356 PUSHEVAL(cx, name, Nullgv);
3358 SAVECOPLINE(&PL_compiling);
3359 CopLINE_set(&PL_compiling, 0);
3363 MUTEX_LOCK(&PL_eval_mutex);
3364 if (PL_eval_owner && PL_eval_owner != thr)
3365 while (PL_eval_owner)
3366 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3367 PL_eval_owner = thr;
3368 MUTEX_UNLOCK(&PL_eval_mutex);
3369 #endif /* USE_THREADS */
3370 return DOCATCH(doeval(G_SCALAR, NULL));
3375 return pp_require();
3381 register PERL_CONTEXT *cx;
3383 I32 gimme = GIMME_V, was = PL_sub_generation;
3384 char tbuf[TYPE_DIGITS(long) + 12];
3385 char *tmpbuf = tbuf;
3390 if (!SvPV(sv,len) || !len)
3392 TAINT_PROPER("eval");
3398 /* switch to eval mode */
3400 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3401 SV *sv = sv_newmortal();
3402 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3403 (unsigned long)++PL_evalseq,
3404 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3408 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3409 SAVECOPFILE_FREE(&PL_compiling);
3410 CopFILE_set(&PL_compiling, tmpbuf+2);
3411 SAVECOPLINE(&PL_compiling);
3412 CopLINE_set(&PL_compiling, 1);
3413 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3414 deleting the eval's FILEGV from the stash before gv_check() runs
3415 (i.e. before run-time proper). To work around the coredump that
3416 ensues, we always turn GvMULTI_on for any globals that were
3417 introduced within evals. See force_ident(). GSAR 96-10-12 */
3418 safestr = savepv(tmpbuf);
3419 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3421 PL_hints = PL_op->op_targ;
3422 SAVESPTR(PL_compiling.cop_warnings);
3423 if (specialWARN(PL_curcop->cop_warnings))
3424 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3426 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3427 SAVEFREESV(PL_compiling.cop_warnings);
3429 SAVESPTR(PL_compiling.cop_io);
3430 if (specialCopIO(PL_curcop->cop_io))
3431 PL_compiling.cop_io = PL_curcop->cop_io;
3433 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3434 SAVEFREESV(PL_compiling.cop_io);
3437 push_return(PL_op->op_next);
3438 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3439 PUSHEVAL(cx, 0, Nullgv);
3441 /* prepare to compile string */
3443 if (PERLDB_LINE && PL_curstash != PL_debstash)
3444 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3447 MUTEX_LOCK(&PL_eval_mutex);
3448 if (PL_eval_owner && PL_eval_owner != thr)
3449 while (PL_eval_owner)
3450 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3451 PL_eval_owner = thr;
3452 MUTEX_UNLOCK(&PL_eval_mutex);
3453 #endif /* USE_THREADS */
3454 ret = doeval(gimme, NULL);
3455 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3456 && ret != PL_op->op_next) { /* Successive compilation. */
3457 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3459 return DOCATCH(ret);
3469 register PERL_CONTEXT *cx;
3471 U8 save_flags = PL_op -> op_flags;
3476 retop = pop_return();
3479 if (gimme == G_VOID)
3481 else if (gimme == G_SCALAR) {
3484 if (SvFLAGS(TOPs) & SVs_TEMP)
3487 *MARK = sv_mortalcopy(TOPs);
3491 *MARK = &PL_sv_undef;
3496 /* in case LEAVE wipes old return values */
3497 for (mark = newsp + 1; mark <= SP; mark++) {
3498 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3499 *mark = sv_mortalcopy(*mark);
3500 TAINT_NOT; /* Each item is independent */
3504 PL_curpm = newpm; /* Don't pop $1 et al till now */
3506 if (AvFILLp(PL_comppad_name) >= 0)
3510 assert(CvDEPTH(PL_compcv) == 1);
3512 CvDEPTH(PL_compcv) = 0;
3515 if (optype == OP_REQUIRE &&
3516 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3518 /* Unassume the success we assumed earlier. */
3519 SV *nsv = cx->blk_eval.old_namesv;
3520 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3521 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3522 /* die_where() did LEAVE, or we won't be here */
3526 if (!(save_flags & OPf_SPECIAL))
3536 register PERL_CONTEXT *cx;
3537 I32 gimme = GIMME_V;
3542 push_return(cLOGOP->op_other->op_next);
3543 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3545 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3547 PL_in_eval = EVAL_INEVAL;
3550 return DOCATCH(PL_op->op_next);
3560 register PERL_CONTEXT *cx;
3568 if (gimme == G_VOID)
3570 else if (gimme == G_SCALAR) {
3573 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3576 *MARK = sv_mortalcopy(TOPs);
3580 *MARK = &PL_sv_undef;
3585 /* in case LEAVE wipes old return values */
3586 for (mark = newsp + 1; mark <= SP; mark++) {
3587 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3588 *mark = sv_mortalcopy(*mark);
3589 TAINT_NOT; /* Each item is independent */
3593 PL_curpm = newpm; /* Don't pop $1 et al till now */
3601 S_doparseform(pTHX_ SV *sv)
3604 register char *s = SvPV_force(sv, len);
3605 register char *send = s + len;
3606 register char *base;
3607 register I32 skipspaces = 0;
3610 bool postspace = FALSE;
3618 Perl_croak(aTHX_ "Null picture in formline");
3620 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3625 *fpc++ = FF_LINEMARK;
3626 noblank = repeat = FALSE;
3644 case ' ': case '\t':
3655 *fpc++ = FF_LITERAL;
3663 *fpc++ = skipspaces;
3667 *fpc++ = FF_NEWLINE;
3671 arg = fpc - linepc + 1;
3678 *fpc++ = FF_LINEMARK;
3679 noblank = repeat = FALSE;
3688 ischop = s[-1] == '^';
3694 arg = (s - base) - 1;
3696 *fpc++ = FF_LITERAL;
3705 *fpc++ = FF_LINEGLOB;
3707 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3708 arg = ischop ? 512 : 0;
3718 arg |= 256 + (s - f);
3720 *fpc++ = s - base; /* fieldsize for FETCH */
3721 *fpc++ = FF_DECIMAL;
3724 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3725 arg = ischop ? 512 : 0;
3727 s++; /* skip the '0' first */
3736 arg |= 256 + (s - f);
3738 *fpc++ = s - base; /* fieldsize for FETCH */
3739 *fpc++ = FF_0DECIMAL;
3744 bool ismore = FALSE;
3747 while (*++s == '>') ;
3748 prespace = FF_SPACE;
3750 else if (*s == '|') {
3751 while (*++s == '|') ;
3752 prespace = FF_HALFSPACE;
3757 while (*++s == '<') ;
3760 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3764 *fpc++ = s - base; /* fieldsize for FETCH */
3766 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3784 { /* need to jump to the next word */
3786 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3787 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3788 s = SvPVX(sv) + SvCUR(sv) + z;
3790 Copy(fops, s, arg, U16);
3792 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3797 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3799 * The original code was written in conjunction with BSD Computer Software
3800 * Research Group at University of California, Berkeley.
3802 * See also: "Optimistic Merge Sort" (SODA '92)
3804 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3806 * The code can be distributed under the same terms as Perl itself.
3811 #include <sys/types.h>
3816 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3817 #define Safefree(VAR) free(VAR)
3818 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3819 #endif /* TESTHARNESS */
3821 typedef char * aptr; /* pointer for arithmetic on sizes */
3822 typedef SV * gptr; /* pointers in our lists */
3824 /* Binary merge internal sort, with a few special mods
3825 ** for the special perl environment it now finds itself in.
3827 ** Things that were once options have been hotwired
3828 ** to values suitable for this use. In particular, we'll always
3829 ** initialize looking for natural runs, we'll always produce stable
3830 ** output, and we'll always do Peter McIlroy's binary merge.
3833 /* Pointer types for arithmetic and storage and convenience casts */
3835 #define APTR(P) ((aptr)(P))
3836 #define GPTP(P) ((gptr *)(P))
3837 #define GPPP(P) ((gptr **)(P))
3840 /* byte offset from pointer P to (larger) pointer Q */
3841 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3843 #define PSIZE sizeof(gptr)
3845 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3848 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3849 #define PNBYTE(N) ((N) << (PSHIFT))
3850 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3852 /* Leave optimization to compiler */
3853 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3854 #define PNBYTE(N) ((N) * (PSIZE))
3855 #define PINDEX(P, N) (GPTP(P) + (N))
3858 /* Pointer into other corresponding to pointer into this */
3859 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3861 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3864 /* Runs are identified by a pointer in the auxilliary list.
3865 ** The pointer is at the start of the list,
3866 ** and it points to the start of the next list.
3867 ** NEXT is used as an lvalue, too.
3870 #define NEXT(P) (*GPPP(P))
3873 /* PTHRESH is the minimum number of pairs with the same sense to justify
3874 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3875 ** not just elements, so PTHRESH == 8 means a run of 16.
3880 /* RTHRESH is the number of elements in a run that must compare low
3881 ** to the low element from the opposing run before we justify
3882 ** doing a binary rampup instead of single stepping.
3883 ** In random input, N in a row low should only happen with
3884 ** probability 2^(1-N), so we can risk that we are dealing
3885 ** with orderly input without paying much when we aren't.
3892 ** Overview of algorithm and variables.
3893 ** The array of elements at list1 will be organized into runs of length 2,
3894 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3895 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3897 ** Unless otherwise specified, pair pointers address the first of two elements.
3899 ** b and b+1 are a pair that compare with sense ``sense''.
3900 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3902 ** p2 parallels b in the list2 array, where runs are defined by
3905 ** t represents the ``top'' of the adjacent pairs that might extend
3906 ** the run beginning at b. Usually, t addresses a pair
3907 ** that compares with opposite sense from (b,b+1).
3908 ** However, it may also address a singleton element at the end of list1,
3909 ** or it may be equal to ``last'', the first element beyond list1.
3911 ** r addresses the Nth pair following b. If this would be beyond t,
3912 ** we back it off to t. Only when r is less than t do we consider the
3913 ** run long enough to consider checking.
3915 ** q addresses a pair such that the pairs at b through q already form a run.
3916 ** Often, q will equal b, indicating we only are sure of the pair itself.
3917 ** However, a search on the previous cycle may have revealed a longer run,
3918 ** so q may be greater than b.
3920 ** p is used to work back from a candidate r, trying to reach q,
3921 ** which would mean b through r would be a run. If we discover such a run,
3922 ** we start q at r and try to push it further towards t.
3923 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3924 ** In any event, after the check (if any), we have two main cases.
3926 ** 1) Short run. b <= q < p <= r <= t.
3927 ** b through q is a run (perhaps trivial)
3928 ** q through p are uninteresting pairs
3929 ** p through r is a run
3931 ** 2) Long run. b < r <= q < t.
3932 ** b through q is a run (of length >= 2 * PTHRESH)
3934 ** Note that degenerate cases are not only possible, but likely.
3935 ** For example, if the pair following b compares with opposite sense,
3936 ** then b == q < p == r == t.
3941 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3944 register gptr *b, *p, *q, *t, *p2;
3945 register gptr c, *last, *r;
3949 last = PINDEX(b, nmemb);
3950 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3951 for (p2 = list2; b < last; ) {
3952 /* We just started, or just reversed sense.
3953 ** Set t at end of pairs with the prevailing sense.
3955 for (p = b+2, t = p; ++p < last; t = ++p) {
3956 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3959 /* Having laid out the playing field, look for long runs */
3961 p = r = b + (2 * PTHRESH);
3962 if (r >= t) p = r = t; /* too short to care about */
3964 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3967 /* b through r is a (long) run.
3968 ** Extend it as far as possible.
3971 while (((p += 2) < t) &&
3972 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3973 r = p = q + 2; /* no simple pairs, no after-run */
3976 if (q > b) { /* run of greater than 2 at b */
3979 /* pick up singleton, if possible */
3981 ((t + 1) == last) &&
3982 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3983 savep = r = p = q = last;
3984 p2 = NEXT(p2) = p2 + (p - b);
3985 if (sense) while (b < --p) {
3992 while (q < p) { /* simple pairs */
3993 p2 = NEXT(p2) = p2 + 2;
4000 if (((b = p) == t) && ((t+1) == last)) {
4012 /* Overview of bmerge variables:
4014 ** list1 and list2 address the main and auxiliary arrays.
4015 ** They swap identities after each merge pass.
4016 ** Base points to the original list1, so we can tell if
4017 ** the pointers ended up where they belonged (or must be copied).
4019 ** When we are merging two lists, f1 and f2 are the next elements
4020 ** on the respective lists. l1 and l2 mark the end of the lists.
4021 ** tp2 is the current location in the merged list.
4023 ** p1 records where f1 started.
4024 ** After the merge, a new descriptor is built there.
4026 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4027 ** It is used to identify and delimit the runs.
4029 ** In the heat of determining where q, the greater of the f1/f2 elements,
4030 ** belongs in the other list, b, t and p, represent bottom, top and probe
4031 ** locations, respectively, in the other list.
4032 ** They make convenient temporary pointers in other places.
4036 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4040 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4041 gptr *aux, *list2, *p2, *last;
4045 if (nmemb <= 1) return; /* sorted trivially */
4046 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4048 dynprep(aTHX_ list1, list2, nmemb, cmp);
4049 last = PINDEX(list2, nmemb);
4050 while (NEXT(list2) != last) {
4051 /* More than one run remains. Do some merging to reduce runs. */
4053 for (tp2 = p2 = list2; p2 != last;) {
4054 /* The new first run begins where the old second list ended.
4055 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4059 f2 = l1 = POTHER(t, list2, list1);
4060 if (t != last) t = NEXT(t);
4061 l2 = POTHER(t, list2, list1);
4063 while (f1 < l1 && f2 < l2) {
4064 /* If head 1 is larger than head 2, find ALL the elements
4065 ** in list 2 strictly less than head1, write them all,
4066 ** then head 1. Then compare the new heads, and repeat,
4067 ** until one or both lists are exhausted.
4069 ** In all comparisons (after establishing
4070 ** which head to merge) the item to merge
4071 ** (at pointer q) is the first operand of
4072 ** the comparison. When we want to know
4073 ** if ``q is strictly less than the other'',
4075 ** cmp(q, other) < 0
4076 ** because stability demands that we treat equality
4077 ** as high when q comes from l2, and as low when
4078 ** q was from l1. So we ask the question by doing
4079 ** cmp(q, other) <= sense
4080 ** and make sense == 0 when equality should look low,
4081 ** and -1 when equality should look high.
4085 if (cmp(aTHX_ *f1, *f2) <= 0) {
4086 q = f2; b = f1; t = l1;
4089 q = f1; b = f2; t = l2;
4096 ** Leave t at something strictly
4097 ** greater than q (or at the end of the list),
4098 ** and b at something strictly less than q.
4100 for (i = 1, run = 0 ;;) {
4101 if ((p = PINDEX(b, i)) >= t) {
4103 if (((p = PINDEX(t, -1)) > b) &&
4104 (cmp(aTHX_ *q, *p) <= sense))
4108 } else if (cmp(aTHX_ *q, *p) <= sense) {
4112 if (++run >= RTHRESH) i += i;
4116 /* q is known to follow b and must be inserted before t.
4117 ** Increment b, so the range of possibilities is [b,t).
4118 ** Round binary split down, to favor early appearance.
4119 ** Adjust b and t until q belongs just before t.
4124 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4125 if (cmp(aTHX_ *q, *p) <= sense) {
4131 /* Copy all the strictly low elements */
4134 FROMTOUPTO(f2, tp2, t);
4137 FROMTOUPTO(f1, tp2, t);
4143 /* Run out remaining list */
4145 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4146 } else FROMTOUPTO(f1, tp2, l1);
4147 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4152 last = PINDEX(list2, nmemb);
4154 if (base == list2) {
4155 last = PINDEX(list1, nmemb);
4156 FROMTOUPTO(list1, list2, last);
4171 sortcv(pTHXo_ SV *a, SV *b)
4173 I32 oldsaveix = PL_savestack_ix;
4174 I32 oldscopeix = PL_scopestack_ix;
4176 GvSV(PL_firstgv) = a;
4177 GvSV(PL_secondgv) = b;
4178 PL_stack_sp = PL_stack_base;
4181 if (PL_stack_sp != PL_stack_base + 1)
4182 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4183 if (!SvNIOKp(*PL_stack_sp))
4184 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4185 result = SvIV(*PL_stack_sp);
4186 while (PL_scopestack_ix > oldscopeix) {
4189 leave_scope(oldsaveix);
4194 sortcv_stacked(pTHXo_ SV *a, SV *b)
4196 I32 oldsaveix = PL_savestack_ix;
4197 I32 oldscopeix = PL_scopestack_ix;
4202 av = (AV*)PL_curpad[0];
4204 av = GvAV(PL_defgv);
4207 if (AvMAX(av) < 1) {
4208 SV** ary = AvALLOC(av);
4209 if (AvARRAY(av) != ary) {
4210 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4211 SvPVX(av) = (char*)ary;
4213 if (AvMAX(av) < 1) {
4216 SvPVX(av) = (char*)ary;
4223 PL_stack_sp = PL_stack_base;
4226 if (PL_stack_sp != PL_stack_base + 1)
4227 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4228 if (!SvNIOKp(*PL_stack_sp))
4229 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4230 result = SvIV(*PL_stack_sp);
4231 while (PL_scopestack_ix > oldscopeix) {
4234 leave_scope(oldsaveix);
4239 sortcv_xsub(pTHXo_ SV *a, SV *b)
4242 I32 oldsaveix = PL_savestack_ix;
4243 I32 oldscopeix = PL_scopestack_ix;
4245 CV *cv=(CV*)PL_sortcop;
4253 (void)(*CvXSUB(cv))(aTHXo_ cv);
4254 if (PL_stack_sp != PL_stack_base + 1)
4255 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4256 if (!SvNIOKp(*PL_stack_sp))
4257 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4258 result = SvIV(*PL_stack_sp);
4259 while (PL_scopestack_ix > oldscopeix) {
4262 leave_scope(oldsaveix);
4268 sv_ncmp(pTHXo_ SV *a, SV *b)
4272 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4276 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4280 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4282 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4284 if (PL_amagic_generation) { \
4285 if (SvAMAGIC(left)||SvAMAGIC(right))\
4286 *svp = amagic_call(left, \
4294 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4297 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4302 I32 i = SvIVX(tmpsv);
4312 return sv_ncmp(aTHXo_ a, b);
4316 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4319 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4324 I32 i = SvIVX(tmpsv);
4334 return sv_i_ncmp(aTHXo_ a, b);
4338 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4341 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4346 I32 i = SvIVX(tmpsv);
4356 return sv_cmp(str1, str2);
4360 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4363 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4368 I32 i = SvIVX(tmpsv);
4378 return sv_cmp_locale(str1, str2);
4382 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4384 SV *datasv = FILTER_DATA(idx);
4385 int filter_has_file = IoLINES(datasv);
4386 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4387 SV *filter_state = (SV *)IoTOP_GV(datasv);
4388 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4391 /* I was having segfault trouble under Linux 2.2.5 after a
4392 parse error occured. (Had to hack around it with a test
4393 for PL_error_count == 0.) Solaris doesn't segfault --
4394 not sure where the trouble is yet. XXX */
4396 if (filter_has_file) {
4397 len = FILTER_READ(idx+1, buf_sv, maxlen);
4400 if (filter_sub && len >= 0) {
4411 PUSHs(sv_2mortal(newSViv(maxlen)));
4413 PUSHs(filter_state);
4416 count = call_sv(filter_sub, G_SCALAR);
4432 IoLINES(datasv) = 0;
4433 if (filter_child_proc) {
4434 SvREFCNT_dec(filter_child_proc);
4435 IoFMT_GV(datasv) = Nullgv;
4438 SvREFCNT_dec(filter_state);
4439 IoTOP_GV(datasv) = Nullgv;
4442 SvREFCNT_dec(filter_sub);
4443 IoBOTTOM_GV(datasv) = Nullgv;
4445 filter_del(run_user_filter);
4454 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4456 return sv_cmp_locale(str1, str2);
4460 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4462 return sv_cmp(str1, str2);
4465 #endif /* PERL_OBJECT */