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 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 dSP; 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 if (sv_isobject(loader))
3170 count = call_method("INC", G_ARRAY);
3172 count = call_sv(loader, G_ARRAY);
3182 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3186 if (SvTYPE(arg) == SVt_PVGV) {
3187 IO *io = GvIO((GV *)arg);
3192 tryrsfp = IoIFP(io);
3193 if (IoTYPE(io) == IoTYPE_PIPE) {
3194 /* reading from a child process doesn't
3195 nest -- when returning from reading
3196 the inner module, the outer one is
3197 unreadable (closed?) I've tried to
3198 save the gv to manage the lifespan of
3199 the pipe, but this didn't help. XXX */
3200 filter_child_proc = (GV *)arg;
3201 (void)SvREFCNT_inc(filter_child_proc);
3204 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3205 PerlIO_close(IoOFP(io));
3217 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3219 (void)SvREFCNT_inc(filter_sub);
3222 filter_state = SP[i];
3223 (void)SvREFCNT_inc(filter_state);
3227 tryrsfp = PerlIO_open("/dev/null",
3241 filter_has_file = 0;
3242 if (filter_child_proc) {
3243 SvREFCNT_dec(filter_child_proc);
3244 filter_child_proc = 0;
3247 SvREFCNT_dec(filter_state);
3251 SvREFCNT_dec(filter_sub);
3256 char *dir = SvPVx(dirsv, n_a);
3257 #ifdef MACOS_TRADITIONAL
3259 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3263 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3265 sv_setpv(namesv, unixdir);
3266 sv_catpv(namesv, unixname);
3268 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3271 TAINT_PROPER("require");
3272 tryname = SvPVX(namesv);
3273 #ifdef MACOS_TRADITIONAL
3275 /* Convert slashes in the name part, but not the directory part, to colons */
3277 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3281 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3283 if (tryname[0] == '.' && tryname[1] == '/')
3291 SAVECOPFILE_FREE(&PL_compiling);
3292 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3293 SvREFCNT_dec(namesv);
3295 if (PL_op->op_type == OP_REQUIRE) {
3296 char *msgstr = name;
3297 if (namesv) { /* did we lookup @INC? */
3298 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3299 SV *dirmsgsv = NEWSV(0, 0);
3300 AV *ar = GvAVn(PL_incgv);
3302 sv_catpvn(msg, " in @INC", 8);
3303 if (instr(SvPVX(msg), ".h "))
3304 sv_catpv(msg, " (change .h to .ph maybe?)");
3305 if (instr(SvPVX(msg), ".ph "))
3306 sv_catpv(msg, " (did you run h2ph?)");
3307 sv_catpv(msg, " (@INC contains:");
3308 for (i = 0; i <= AvFILL(ar); i++) {
3309 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3310 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3311 sv_catsv(msg, dirmsgsv);
3313 sv_catpvn(msg, ")", 1);
3314 SvREFCNT_dec(dirmsgsv);
3315 msgstr = SvPV_nolen(msg);
3317 DIE(aTHX_ "Can't locate %s", msgstr);
3323 SETERRNO(0, SS$_NORMAL);
3325 /* Assume success here to prevent recursive requirement. */
3326 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3327 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3331 lex_start(sv_2mortal(newSVpvn("",0)));
3332 SAVEGENERICSV(PL_rsfp_filters);
3333 PL_rsfp_filters = Nullav;
3338 SAVESPTR(PL_compiling.cop_warnings);
3339 if (PL_dowarn & G_WARN_ALL_ON)
3340 PL_compiling.cop_warnings = pWARN_ALL ;
3341 else if (PL_dowarn & G_WARN_ALL_OFF)
3342 PL_compiling.cop_warnings = pWARN_NONE ;
3344 PL_compiling.cop_warnings = pWARN_STD ;
3345 SAVESPTR(PL_compiling.cop_io);
3346 PL_compiling.cop_io = Nullsv;
3348 if (filter_sub || filter_child_proc) {
3349 SV *datasv = filter_add(run_user_filter, Nullsv);
3350 IoLINES(datasv) = filter_has_file;
3351 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3352 IoTOP_GV(datasv) = (GV *)filter_state;
3353 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3356 /* switch to eval mode */
3357 push_return(PL_op->op_next);
3358 PUSHBLOCK(cx, CXt_EVAL, SP);
3359 PUSHEVAL(cx, name, Nullgv);
3361 SAVECOPLINE(&PL_compiling);
3362 CopLINE_set(&PL_compiling, 0);
3366 MUTEX_LOCK(&PL_eval_mutex);
3367 if (PL_eval_owner && PL_eval_owner != thr)
3368 while (PL_eval_owner)
3369 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3370 PL_eval_owner = thr;
3371 MUTEX_UNLOCK(&PL_eval_mutex);
3372 #endif /* USE_THREADS */
3373 return DOCATCH(doeval(G_SCALAR, NULL));
3378 return pp_require();
3384 register PERL_CONTEXT *cx;
3386 I32 gimme = GIMME_V, was = PL_sub_generation;
3387 char tbuf[TYPE_DIGITS(long) + 12];
3388 char *tmpbuf = tbuf;
3393 if (!SvPV(sv,len) || !len)
3395 TAINT_PROPER("eval");
3401 /* switch to eval mode */
3403 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3404 SV *sv = sv_newmortal();
3405 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3406 (unsigned long)++PL_evalseq,
3407 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3411 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3412 SAVECOPFILE_FREE(&PL_compiling);
3413 CopFILE_set(&PL_compiling, tmpbuf+2);
3414 SAVECOPLINE(&PL_compiling);
3415 CopLINE_set(&PL_compiling, 1);
3416 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3417 deleting the eval's FILEGV from the stash before gv_check() runs
3418 (i.e. before run-time proper). To work around the coredump that
3419 ensues, we always turn GvMULTI_on for any globals that were
3420 introduced within evals. See force_ident(). GSAR 96-10-12 */
3421 safestr = savepv(tmpbuf);
3422 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3424 PL_hints = PL_op->op_targ;
3425 SAVESPTR(PL_compiling.cop_warnings);
3426 if (specialWARN(PL_curcop->cop_warnings))
3427 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3429 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3430 SAVEFREESV(PL_compiling.cop_warnings);
3432 SAVESPTR(PL_compiling.cop_io);
3433 if (specialCopIO(PL_curcop->cop_io))
3434 PL_compiling.cop_io = PL_curcop->cop_io;
3436 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3437 SAVEFREESV(PL_compiling.cop_io);
3440 push_return(PL_op->op_next);
3441 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3442 PUSHEVAL(cx, 0, Nullgv);
3444 /* prepare to compile string */
3446 if (PERLDB_LINE && PL_curstash != PL_debstash)
3447 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3450 MUTEX_LOCK(&PL_eval_mutex);
3451 if (PL_eval_owner && PL_eval_owner != thr)
3452 while (PL_eval_owner)
3453 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3454 PL_eval_owner = thr;
3455 MUTEX_UNLOCK(&PL_eval_mutex);
3456 #endif /* USE_THREADS */
3457 ret = doeval(gimme, NULL);
3458 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3459 && ret != PL_op->op_next) { /* Successive compilation. */
3460 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3462 return DOCATCH(ret);
3472 register PERL_CONTEXT *cx;
3474 U8 save_flags = PL_op -> op_flags;
3479 retop = pop_return();
3482 if (gimme == G_VOID)
3484 else if (gimme == G_SCALAR) {
3487 if (SvFLAGS(TOPs) & SVs_TEMP)
3490 *MARK = sv_mortalcopy(TOPs);
3494 *MARK = &PL_sv_undef;
3499 /* in case LEAVE wipes old return values */
3500 for (mark = newsp + 1; mark <= SP; mark++) {
3501 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3502 *mark = sv_mortalcopy(*mark);
3503 TAINT_NOT; /* Each item is independent */
3507 PL_curpm = newpm; /* Don't pop $1 et al till now */
3509 if (AvFILLp(PL_comppad_name) >= 0)
3513 assert(CvDEPTH(PL_compcv) == 1);
3515 CvDEPTH(PL_compcv) = 0;
3518 if (optype == OP_REQUIRE &&
3519 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3521 /* Unassume the success we assumed earlier. */
3522 SV *nsv = cx->blk_eval.old_namesv;
3523 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3524 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3525 /* die_where() did LEAVE, or we won't be here */
3529 if (!(save_flags & OPf_SPECIAL))
3539 register PERL_CONTEXT *cx;
3540 I32 gimme = GIMME_V;
3545 push_return(cLOGOP->op_other->op_next);
3546 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3548 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3550 PL_in_eval = EVAL_INEVAL;
3553 return DOCATCH(PL_op->op_next);
3563 register PERL_CONTEXT *cx;
3571 if (gimme == G_VOID)
3573 else if (gimme == G_SCALAR) {
3576 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3579 *MARK = sv_mortalcopy(TOPs);
3583 *MARK = &PL_sv_undef;
3588 /* in case LEAVE wipes old return values */
3589 for (mark = newsp + 1; mark <= SP; mark++) {
3590 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3591 *mark = sv_mortalcopy(*mark);
3592 TAINT_NOT; /* Each item is independent */
3596 PL_curpm = newpm; /* Don't pop $1 et al till now */
3604 S_doparseform(pTHX_ SV *sv)
3607 register char *s = SvPV_force(sv, len);
3608 register char *send = s + len;
3609 register char *base;
3610 register I32 skipspaces = 0;
3613 bool postspace = FALSE;
3621 Perl_croak(aTHX_ "Null picture in formline");
3623 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3628 *fpc++ = FF_LINEMARK;
3629 noblank = repeat = FALSE;
3647 case ' ': case '\t':
3658 *fpc++ = FF_LITERAL;
3666 *fpc++ = skipspaces;
3670 *fpc++ = FF_NEWLINE;
3674 arg = fpc - linepc + 1;
3681 *fpc++ = FF_LINEMARK;
3682 noblank = repeat = FALSE;
3691 ischop = s[-1] == '^';
3697 arg = (s - base) - 1;
3699 *fpc++ = FF_LITERAL;
3708 *fpc++ = FF_LINEGLOB;
3710 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3711 arg = ischop ? 512 : 0;
3721 arg |= 256 + (s - f);
3723 *fpc++ = s - base; /* fieldsize for FETCH */
3724 *fpc++ = FF_DECIMAL;
3727 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3728 arg = ischop ? 512 : 0;
3730 s++; /* skip the '0' first */
3739 arg |= 256 + (s - f);
3741 *fpc++ = s - base; /* fieldsize for FETCH */
3742 *fpc++ = FF_0DECIMAL;
3747 bool ismore = FALSE;
3750 while (*++s == '>') ;
3751 prespace = FF_SPACE;
3753 else if (*s == '|') {
3754 while (*++s == '|') ;
3755 prespace = FF_HALFSPACE;
3760 while (*++s == '<') ;
3763 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3767 *fpc++ = s - base; /* fieldsize for FETCH */
3769 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3787 { /* need to jump to the next word */
3789 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3790 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3791 s = SvPVX(sv) + SvCUR(sv) + z;
3793 Copy(fops, s, arg, U16);
3795 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3800 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3802 * The original code was written in conjunction with BSD Computer Software
3803 * Research Group at University of California, Berkeley.
3805 * See also: "Optimistic Merge Sort" (SODA '92)
3807 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3809 * The code can be distributed under the same terms as Perl itself.
3814 #include <sys/types.h>
3819 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3820 #define Safefree(VAR) free(VAR)
3821 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3822 #endif /* TESTHARNESS */
3824 typedef char * aptr; /* pointer for arithmetic on sizes */
3825 typedef SV * gptr; /* pointers in our lists */
3827 /* Binary merge internal sort, with a few special mods
3828 ** for the special perl environment it now finds itself in.
3830 ** Things that were once options have been hotwired
3831 ** to values suitable for this use. In particular, we'll always
3832 ** initialize looking for natural runs, we'll always produce stable
3833 ** output, and we'll always do Peter McIlroy's binary merge.
3836 /* Pointer types for arithmetic and storage and convenience casts */
3838 #define APTR(P) ((aptr)(P))
3839 #define GPTP(P) ((gptr *)(P))
3840 #define GPPP(P) ((gptr **)(P))
3843 /* byte offset from pointer P to (larger) pointer Q */
3844 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3846 #define PSIZE sizeof(gptr)
3848 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3851 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3852 #define PNBYTE(N) ((N) << (PSHIFT))
3853 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3855 /* Leave optimization to compiler */
3856 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3857 #define PNBYTE(N) ((N) * (PSIZE))
3858 #define PINDEX(P, N) (GPTP(P) + (N))
3861 /* Pointer into other corresponding to pointer into this */
3862 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3864 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3867 /* Runs are identified by a pointer in the auxilliary list.
3868 ** The pointer is at the start of the list,
3869 ** and it points to the start of the next list.
3870 ** NEXT is used as an lvalue, too.
3873 #define NEXT(P) (*GPPP(P))
3876 /* PTHRESH is the minimum number of pairs with the same sense to justify
3877 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3878 ** not just elements, so PTHRESH == 8 means a run of 16.
3883 /* RTHRESH is the number of elements in a run that must compare low
3884 ** to the low element from the opposing run before we justify
3885 ** doing a binary rampup instead of single stepping.
3886 ** In random input, N in a row low should only happen with
3887 ** probability 2^(1-N), so we can risk that we are dealing
3888 ** with orderly input without paying much when we aren't.
3895 ** Overview of algorithm and variables.
3896 ** The array of elements at list1 will be organized into runs of length 2,
3897 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3898 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3900 ** Unless otherwise specified, pair pointers address the first of two elements.
3902 ** b and b+1 are a pair that compare with sense ``sense''.
3903 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3905 ** p2 parallels b in the list2 array, where runs are defined by
3908 ** t represents the ``top'' of the adjacent pairs that might extend
3909 ** the run beginning at b. Usually, t addresses a pair
3910 ** that compares with opposite sense from (b,b+1).
3911 ** However, it may also address a singleton element at the end of list1,
3912 ** or it may be equal to ``last'', the first element beyond list1.
3914 ** r addresses the Nth pair following b. If this would be beyond t,
3915 ** we back it off to t. Only when r is less than t do we consider the
3916 ** run long enough to consider checking.
3918 ** q addresses a pair such that the pairs at b through q already form a run.
3919 ** Often, q will equal b, indicating we only are sure of the pair itself.
3920 ** However, a search on the previous cycle may have revealed a longer run,
3921 ** so q may be greater than b.
3923 ** p is used to work back from a candidate r, trying to reach q,
3924 ** which would mean b through r would be a run. If we discover such a run,
3925 ** we start q at r and try to push it further towards t.
3926 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3927 ** In any event, after the check (if any), we have two main cases.
3929 ** 1) Short run. b <= q < p <= r <= t.
3930 ** b through q is a run (perhaps trivial)
3931 ** q through p are uninteresting pairs
3932 ** p through r is a run
3934 ** 2) Long run. b < r <= q < t.
3935 ** b through q is a run (of length >= 2 * PTHRESH)
3937 ** Note that degenerate cases are not only possible, but likely.
3938 ** For example, if the pair following b compares with opposite sense,
3939 ** then b == q < p == r == t.
3944 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3947 register gptr *b, *p, *q, *t, *p2;
3948 register gptr c, *last, *r;
3952 last = PINDEX(b, nmemb);
3953 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3954 for (p2 = list2; b < last; ) {
3955 /* We just started, or just reversed sense.
3956 ** Set t at end of pairs with the prevailing sense.
3958 for (p = b+2, t = p; ++p < last; t = ++p) {
3959 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3962 /* Having laid out the playing field, look for long runs */
3964 p = r = b + (2 * PTHRESH);
3965 if (r >= t) p = r = t; /* too short to care about */
3967 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3970 /* b through r is a (long) run.
3971 ** Extend it as far as possible.
3974 while (((p += 2) < t) &&
3975 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3976 r = p = q + 2; /* no simple pairs, no after-run */
3979 if (q > b) { /* run of greater than 2 at b */
3982 /* pick up singleton, if possible */
3984 ((t + 1) == last) &&
3985 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3986 savep = r = p = q = last;
3987 p2 = NEXT(p2) = p2 + (p - b);
3988 if (sense) while (b < --p) {
3995 while (q < p) { /* simple pairs */
3996 p2 = NEXT(p2) = p2 + 2;
4003 if (((b = p) == t) && ((t+1) == last)) {
4015 /* Overview of bmerge variables:
4017 ** list1 and list2 address the main and auxiliary arrays.
4018 ** They swap identities after each merge pass.
4019 ** Base points to the original list1, so we can tell if
4020 ** the pointers ended up where they belonged (or must be copied).
4022 ** When we are merging two lists, f1 and f2 are the next elements
4023 ** on the respective lists. l1 and l2 mark the end of the lists.
4024 ** tp2 is the current location in the merged list.
4026 ** p1 records where f1 started.
4027 ** After the merge, a new descriptor is built there.
4029 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4030 ** It is used to identify and delimit the runs.
4032 ** In the heat of determining where q, the greater of the f1/f2 elements,
4033 ** belongs in the other list, b, t and p, represent bottom, top and probe
4034 ** locations, respectively, in the other list.
4035 ** They make convenient temporary pointers in other places.
4039 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4043 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4044 gptr *aux, *list2, *p2, *last;
4048 if (nmemb <= 1) return; /* sorted trivially */
4049 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4051 dynprep(aTHX_ list1, list2, nmemb, cmp);
4052 last = PINDEX(list2, nmemb);
4053 while (NEXT(list2) != last) {
4054 /* More than one run remains. Do some merging to reduce runs. */
4056 for (tp2 = p2 = list2; p2 != last;) {
4057 /* The new first run begins where the old second list ended.
4058 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4062 f2 = l1 = POTHER(t, list2, list1);
4063 if (t != last) t = NEXT(t);
4064 l2 = POTHER(t, list2, list1);
4066 while (f1 < l1 && f2 < l2) {
4067 /* If head 1 is larger than head 2, find ALL the elements
4068 ** in list 2 strictly less than head1, write them all,
4069 ** then head 1. Then compare the new heads, and repeat,
4070 ** until one or both lists are exhausted.
4072 ** In all comparisons (after establishing
4073 ** which head to merge) the item to merge
4074 ** (at pointer q) is the first operand of
4075 ** the comparison. When we want to know
4076 ** if ``q is strictly less than the other'',
4078 ** cmp(q, other) < 0
4079 ** because stability demands that we treat equality
4080 ** as high when q comes from l2, and as low when
4081 ** q was from l1. So we ask the question by doing
4082 ** cmp(q, other) <= sense
4083 ** and make sense == 0 when equality should look low,
4084 ** and -1 when equality should look high.
4088 if (cmp(aTHX_ *f1, *f2) <= 0) {
4089 q = f2; b = f1; t = l1;
4092 q = f1; b = f2; t = l2;
4099 ** Leave t at something strictly
4100 ** greater than q (or at the end of the list),
4101 ** and b at something strictly less than q.
4103 for (i = 1, run = 0 ;;) {
4104 if ((p = PINDEX(b, i)) >= t) {
4106 if (((p = PINDEX(t, -1)) > b) &&
4107 (cmp(aTHX_ *q, *p) <= sense))
4111 } else if (cmp(aTHX_ *q, *p) <= sense) {
4115 if (++run >= RTHRESH) i += i;
4119 /* q is known to follow b and must be inserted before t.
4120 ** Increment b, so the range of possibilities is [b,t).
4121 ** Round binary split down, to favor early appearance.
4122 ** Adjust b and t until q belongs just before t.
4127 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4128 if (cmp(aTHX_ *q, *p) <= sense) {
4134 /* Copy all the strictly low elements */
4137 FROMTOUPTO(f2, tp2, t);
4140 FROMTOUPTO(f1, tp2, t);
4146 /* Run out remaining list */
4148 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4149 } else FROMTOUPTO(f1, tp2, l1);
4150 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4155 last = PINDEX(list2, nmemb);
4157 if (base == list2) {
4158 last = PINDEX(list1, nmemb);
4159 FROMTOUPTO(list1, list2, last);
4174 sortcv(pTHXo_ SV *a, SV *b)
4176 I32 oldsaveix = PL_savestack_ix;
4177 I32 oldscopeix = PL_scopestack_ix;
4179 GvSV(PL_firstgv) = a;
4180 GvSV(PL_secondgv) = b;
4181 PL_stack_sp = PL_stack_base;
4184 if (PL_stack_sp != PL_stack_base + 1)
4185 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4186 if (!SvNIOKp(*PL_stack_sp))
4187 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4188 result = SvIV(*PL_stack_sp);
4189 while (PL_scopestack_ix > oldscopeix) {
4192 leave_scope(oldsaveix);
4197 sortcv_stacked(pTHXo_ SV *a, SV *b)
4199 I32 oldsaveix = PL_savestack_ix;
4200 I32 oldscopeix = PL_scopestack_ix;
4205 av = (AV*)PL_curpad[0];
4207 av = GvAV(PL_defgv);
4210 if (AvMAX(av) < 1) {
4211 SV** ary = AvALLOC(av);
4212 if (AvARRAY(av) != ary) {
4213 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4214 SvPVX(av) = (char*)ary;
4216 if (AvMAX(av) < 1) {
4219 SvPVX(av) = (char*)ary;
4226 PL_stack_sp = PL_stack_base;
4229 if (PL_stack_sp != PL_stack_base + 1)
4230 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4231 if (!SvNIOKp(*PL_stack_sp))
4232 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4233 result = SvIV(*PL_stack_sp);
4234 while (PL_scopestack_ix > oldscopeix) {
4237 leave_scope(oldsaveix);
4242 sortcv_xsub(pTHXo_ SV *a, SV *b)
4245 I32 oldsaveix = PL_savestack_ix;
4246 I32 oldscopeix = PL_scopestack_ix;
4248 CV *cv=(CV*)PL_sortcop;
4256 (void)(*CvXSUB(cv))(aTHXo_ cv);
4257 if (PL_stack_sp != PL_stack_base + 1)
4258 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4259 if (!SvNIOKp(*PL_stack_sp))
4260 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4261 result = SvIV(*PL_stack_sp);
4262 while (PL_scopestack_ix > oldscopeix) {
4265 leave_scope(oldsaveix);
4271 sv_ncmp(pTHXo_ SV *a, SV *b)
4275 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4279 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4283 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4285 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4287 if (PL_amagic_generation) { \
4288 if (SvAMAGIC(left)||SvAMAGIC(right))\
4289 *svp = amagic_call(left, \
4297 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4300 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4305 I32 i = SvIVX(tmpsv);
4315 return sv_ncmp(aTHXo_ a, b);
4319 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4322 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4327 I32 i = SvIVX(tmpsv);
4337 return sv_i_ncmp(aTHXo_ a, b);
4341 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4344 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4349 I32 i = SvIVX(tmpsv);
4359 return sv_cmp(str1, str2);
4363 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4366 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4371 I32 i = SvIVX(tmpsv);
4381 return sv_cmp_locale(str1, str2);
4385 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4387 SV *datasv = FILTER_DATA(idx);
4388 int filter_has_file = IoLINES(datasv);
4389 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4390 SV *filter_state = (SV *)IoTOP_GV(datasv);
4391 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4394 /* I was having segfault trouble under Linux 2.2.5 after a
4395 parse error occured. (Had to hack around it with a test
4396 for PL_error_count == 0.) Solaris doesn't segfault --
4397 not sure where the trouble is yet. XXX */
4399 if (filter_has_file) {
4400 len = FILTER_READ(idx+1, buf_sv, maxlen);
4403 if (filter_sub && len >= 0) {
4414 PUSHs(sv_2mortal(newSViv(maxlen)));
4416 PUSHs(filter_state);
4419 count = call_sv(filter_sub, G_SCALAR);
4435 IoLINES(datasv) = 0;
4436 if (filter_child_proc) {
4437 SvREFCNT_dec(filter_child_proc);
4438 IoFMT_GV(datasv) = Nullgv;
4441 SvREFCNT_dec(filter_state);
4442 IoTOP_GV(datasv) = Nullgv;
4445 SvREFCNT_dec(filter_sub);
4446 IoBOTTOM_GV(datasv) = Nullgv;
4448 filter_del(run_user_filter);
4457 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4459 return sv_cmp_locale(str1, str2);
4463 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4465 return sv_cmp(str1, str2);
4468 #endif /* PERL_OBJECT */