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 & DEBUG_DB_RECURSE_FLAG))
1747 /* don't do recursive DB::DB call */
1759 push_return(PL_op->op_next);
1760 PUSHBLOCK(cx, CXt_SUB, SP);
1763 (void)SvREFCNT_inc(cv);
1764 SAVEVPTR(PL_curpad);
1765 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1766 RETURNOP(CvSTART(cv));
1780 register PERL_CONTEXT *cx;
1781 I32 gimme = GIMME_V;
1783 U32 cxtype = CXt_LOOP;
1792 if (PL_op->op_flags & OPf_SPECIAL) {
1793 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1794 SAVEGENERICSV(*svp);
1798 #endif /* USE_THREADS */
1799 if (PL_op->op_targ) {
1800 #ifndef USE_ITHREADS
1801 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1804 SAVEPADSV(PL_op->op_targ);
1805 iterdata = (void*)PL_op->op_targ;
1806 cxtype |= CXp_PADVAR;
1811 svp = &GvSV(gv); /* symbol table variable */
1812 SAVEGENERICSV(*svp);
1815 iterdata = (void*)gv;
1821 PUSHBLOCK(cx, cxtype, SP);
1823 PUSHLOOP(cx, iterdata, MARK);
1825 PUSHLOOP(cx, svp, MARK);
1827 if (PL_op->op_flags & OPf_STACKED) {
1828 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1829 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1831 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1832 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1833 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1834 looks_like_number((SV*)cx->blk_loop.iterary) &&
1835 *SvPVX(cx->blk_loop.iterary) != '0'))
1837 if (SvNV(sv) < IV_MIN ||
1838 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1839 DIE(aTHX_ "Range iterator outside integer range");
1840 cx->blk_loop.iterix = SvIV(sv);
1841 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1844 cx->blk_loop.iterlval = newSVsv(sv);
1848 cx->blk_loop.iterary = PL_curstack;
1849 AvFILLp(PL_curstack) = SP - PL_stack_base;
1850 cx->blk_loop.iterix = MARK - PL_stack_base;
1859 register PERL_CONTEXT *cx;
1860 I32 gimme = GIMME_V;
1866 PUSHBLOCK(cx, CXt_LOOP, SP);
1867 PUSHLOOP(cx, 0, SP);
1875 register PERL_CONTEXT *cx;
1883 newsp = PL_stack_base + cx->blk_loop.resetsp;
1886 if (gimme == G_VOID)
1888 else if (gimme == G_SCALAR) {
1890 *++newsp = sv_mortalcopy(*SP);
1892 *++newsp = &PL_sv_undef;
1896 *++newsp = sv_mortalcopy(*++mark);
1897 TAINT_NOT; /* Each item is independent */
1903 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1904 PL_curpm = newpm; /* ... and pop $1 et al */
1916 register PERL_CONTEXT *cx;
1917 bool popsub2 = FALSE;
1918 bool clear_errsv = FALSE;
1925 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1926 if (cxstack_ix == PL_sortcxix
1927 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1929 if (cxstack_ix > PL_sortcxix)
1930 dounwind(PL_sortcxix);
1931 AvARRAY(PL_curstack)[1] = *SP;
1932 PL_stack_sp = PL_stack_base + 1;
1937 cxix = dopoptosub(cxstack_ix);
1939 DIE(aTHX_ "Can't return outside a subroutine");
1940 if (cxix < cxstack_ix)
1944 switch (CxTYPE(cx)) {
1949 if (!(PL_in_eval & EVAL_KEEPERR))
1954 if (AvFILLp(PL_comppad_name) >= 0)
1957 if (optype == OP_REQUIRE &&
1958 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1960 /* Unassume the success we assumed earlier. */
1961 SV *nsv = cx->blk_eval.old_namesv;
1962 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1963 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1970 DIE(aTHX_ "panic: return");
1974 if (gimme == G_SCALAR) {
1977 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1979 *++newsp = SvREFCNT_inc(*SP);
1984 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1986 *++newsp = sv_mortalcopy(sv);
1991 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1994 *++newsp = sv_mortalcopy(*SP);
1997 *++newsp = &PL_sv_undef;
1999 else if (gimme == G_ARRAY) {
2000 while (++MARK <= SP) {
2001 *++newsp = (popsub2 && SvTEMP(*MARK))
2002 ? *MARK : sv_mortalcopy(*MARK);
2003 TAINT_NOT; /* Each item is independent */
2006 PL_stack_sp = newsp;
2008 /* Stack values are safe: */
2010 POPSUB(cx,sv); /* release CV and @_ ... */
2014 PL_curpm = newpm; /* ... and pop $1 et al */
2020 return pop_return();
2027 register PERL_CONTEXT *cx;
2037 if (PL_op->op_flags & OPf_SPECIAL) {
2038 cxix = dopoptoloop(cxstack_ix);
2040 DIE(aTHX_ "Can't \"last\" outside a loop block");
2043 cxix = dopoptolabel(cPVOP->op_pv);
2045 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2047 if (cxix < cxstack_ix)
2052 switch (CxTYPE(cx)) {
2055 newsp = PL_stack_base + cx->blk_loop.resetsp;
2056 nextop = cx->blk_loop.last_op->op_next;
2060 nextop = pop_return();
2064 nextop = pop_return();
2068 nextop = pop_return();
2071 DIE(aTHX_ "panic: last");
2075 if (gimme == G_SCALAR) {
2077 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2078 ? *SP : sv_mortalcopy(*SP);
2080 *++newsp = &PL_sv_undef;
2082 else if (gimme == G_ARRAY) {
2083 while (++MARK <= SP) {
2084 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2085 ? *MARK : sv_mortalcopy(*MARK);
2086 TAINT_NOT; /* Each item is independent */
2092 /* Stack values are safe: */
2095 POPLOOP(cx); /* release loop vars ... */
2099 POPSUB(cx,sv); /* release CV and @_ ... */
2102 PL_curpm = newpm; /* ... and pop $1 et al */
2112 register PERL_CONTEXT *cx;
2115 if (PL_op->op_flags & OPf_SPECIAL) {
2116 cxix = dopoptoloop(cxstack_ix);
2118 DIE(aTHX_ "Can't \"next\" outside a loop block");
2121 cxix = dopoptolabel(cPVOP->op_pv);
2123 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2125 if (cxix < cxstack_ix)
2128 /* clear off anything above the scope we're re-entering, but
2129 * save the rest until after a possible continue block */
2130 inner = PL_scopestack_ix;
2132 if (PL_scopestack_ix < inner)
2133 leave_scope(PL_scopestack[PL_scopestack_ix]);
2134 return cx->blk_loop.next_op;
2140 register PERL_CONTEXT *cx;
2143 if (PL_op->op_flags & OPf_SPECIAL) {
2144 cxix = dopoptoloop(cxstack_ix);
2146 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2149 cxix = dopoptolabel(cPVOP->op_pv);
2151 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2153 if (cxix < cxstack_ix)
2157 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2158 LEAVE_SCOPE(oldsave);
2159 return cx->blk_loop.redo_op;
2163 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2167 static char too_deep[] = "Target of goto is too deeply nested";
2170 Perl_croak(aTHX_ too_deep);
2171 if (o->op_type == OP_LEAVE ||
2172 o->op_type == OP_SCOPE ||
2173 o->op_type == OP_LEAVELOOP ||
2174 o->op_type == OP_LEAVETRY)
2176 *ops++ = cUNOPo->op_first;
2178 Perl_croak(aTHX_ too_deep);
2181 if (o->op_flags & OPf_KIDS) {
2182 /* First try all the kids at this level, since that's likeliest. */
2183 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2184 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2185 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2188 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2189 if (kid == PL_lastgotoprobe)
2191 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2193 (ops[-1]->op_type != OP_NEXTSTATE &&
2194 ops[-1]->op_type != OP_DBSTATE)))
2196 if ((o = dofindlabel(kid, label, ops, oplimit)))
2215 register PERL_CONTEXT *cx;
2216 #define GOTO_DEPTH 64
2217 OP *enterops[GOTO_DEPTH];
2219 int do_dump = (PL_op->op_type == OP_DUMP);
2220 static char must_have_label[] = "goto must have label";
2223 if (PL_op->op_flags & OPf_STACKED) {
2227 /* This egregious kludge implements goto &subroutine */
2228 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2230 register PERL_CONTEXT *cx;
2231 CV* cv = (CV*)SvRV(sv);
2237 if (!CvROOT(cv) && !CvXSUB(cv)) {
2242 /* autoloaded stub? */
2243 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2245 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2246 GvNAMELEN(gv), FALSE);
2247 if (autogv && (cv = GvCV(autogv)))
2249 tmpstr = sv_newmortal();
2250 gv_efullname3(tmpstr, gv, Nullch);
2251 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2253 DIE(aTHX_ "Goto undefined subroutine");
2256 /* First do some returnish stuff. */
2257 cxix = dopoptosub(cxstack_ix);
2259 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2260 if (cxix < cxstack_ix)
2263 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2264 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2266 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2267 /* put @_ back onto stack */
2268 AV* av = cx->blk_sub.argarray;
2270 items = AvFILLp(av) + 1;
2272 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2273 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2274 PL_stack_sp += items;
2276 SvREFCNT_dec(GvAV(PL_defgv));
2277 GvAV(PL_defgv) = cx->blk_sub.savearray;
2278 #endif /* USE_THREADS */
2279 /* abandon @_ if it got reified */
2281 (void)sv_2mortal((SV*)av); /* delay until return */
2283 av_extend(av, items-1);
2284 AvFLAGS(av) = AVf_REIFY;
2285 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2288 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2291 av = (AV*)PL_curpad[0];
2293 av = GvAV(PL_defgv);
2295 items = AvFILLp(av) + 1;
2297 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2298 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2299 PL_stack_sp += items;
2301 if (CxTYPE(cx) == CXt_SUB &&
2302 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2303 SvREFCNT_dec(cx->blk_sub.cv);
2304 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2305 LEAVE_SCOPE(oldsave);
2307 /* Now do some callish stuff. */
2310 #ifdef PERL_XSUB_OLDSTYLE
2311 if (CvOLDSTYLE(cv)) {
2312 I32 (*fp3)(int,int,int);
2317 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2318 items = (*fp3)(CvXSUBANY(cv).any_i32,
2319 mark - PL_stack_base + 1,
2321 SP = PL_stack_base + items;
2324 #endif /* PERL_XSUB_OLDSTYLE */
2329 PL_stack_sp--; /* There is no cv arg. */
2330 /* Push a mark for the start of arglist */
2332 (void)(*CvXSUB(cv))(aTHXo_ cv);
2333 /* Pop the current context like a decent sub should */
2334 POPBLOCK(cx, PL_curpm);
2335 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2338 return pop_return();
2341 AV* padlist = CvPADLIST(cv);
2342 SV** svp = AvARRAY(padlist);
2343 if (CxTYPE(cx) == CXt_EVAL) {
2344 PL_in_eval = cx->blk_eval.old_in_eval;
2345 PL_eval_root = cx->blk_eval.old_eval_root;
2346 cx->cx_type = CXt_SUB;
2347 cx->blk_sub.hasargs = 0;
2349 cx->blk_sub.cv = cv;
2350 cx->blk_sub.olddepth = CvDEPTH(cv);
2352 if (CvDEPTH(cv) < 2)
2353 (void)SvREFCNT_inc(cv);
2354 else { /* save temporaries on recursion? */
2355 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2356 sub_crush_depth(cv);
2357 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2358 AV *newpad = newAV();
2359 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2360 I32 ix = AvFILLp((AV*)svp[1]);
2361 I32 names_fill = AvFILLp((AV*)svp[0]);
2362 svp = AvARRAY(svp[0]);
2363 for ( ;ix > 0; ix--) {
2364 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2365 char *name = SvPVX(svp[ix]);
2366 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2369 /* outer lexical or anon code */
2370 av_store(newpad, ix,
2371 SvREFCNT_inc(oldpad[ix]) );
2373 else { /* our own lexical */
2375 av_store(newpad, ix, sv = (SV*)newAV());
2376 else if (*name == '%')
2377 av_store(newpad, ix, sv = (SV*)newHV());
2379 av_store(newpad, ix, sv = NEWSV(0,0));
2383 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2384 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2387 av_store(newpad, ix, sv = NEWSV(0,0));
2391 if (cx->blk_sub.hasargs) {
2394 av_store(newpad, 0, (SV*)av);
2395 AvFLAGS(av) = AVf_REIFY;
2397 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2398 AvFILLp(padlist) = CvDEPTH(cv);
2399 svp = AvARRAY(padlist);
2403 if (!cx->blk_sub.hasargs) {
2404 AV* av = (AV*)PL_curpad[0];
2406 items = AvFILLp(av) + 1;
2408 /* Mark is at the end of the stack. */
2410 Copy(AvARRAY(av), SP + 1, items, SV*);
2415 #endif /* USE_THREADS */
2416 SAVEVPTR(PL_curpad);
2417 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2419 if (cx->blk_sub.hasargs)
2420 #endif /* USE_THREADS */
2422 AV* av = (AV*)PL_curpad[0];
2426 cx->blk_sub.savearray = GvAV(PL_defgv);
2427 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2428 #endif /* USE_THREADS */
2429 cx->blk_sub.oldcurpad = PL_curpad;
2430 cx->blk_sub.argarray = av;
2433 if (items >= AvMAX(av) + 1) {
2435 if (AvARRAY(av) != ary) {
2436 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2437 SvPVX(av) = (char*)ary;
2439 if (items >= AvMAX(av) + 1) {
2440 AvMAX(av) = items - 1;
2441 Renew(ary,items+1,SV*);
2443 SvPVX(av) = (char*)ary;
2446 Copy(mark,AvARRAY(av),items,SV*);
2447 AvFILLp(av) = items - 1;
2448 assert(!AvREAL(av));
2455 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2457 * We do not care about using sv to call CV;
2458 * it's for informational purposes only.
2460 SV *sv = GvSV(PL_DBsub);
2463 if (PERLDB_SUB_NN) {
2464 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2467 gv_efullname3(sv, CvGV(cv), Nullch);
2470 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2471 PUSHMARK( PL_stack_sp );
2472 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2476 RETURNOP(CvSTART(cv));
2480 label = SvPV(sv,n_a);
2481 if (!(do_dump || *label))
2482 DIE(aTHX_ must_have_label);
2485 else if (PL_op->op_flags & OPf_SPECIAL) {
2487 DIE(aTHX_ must_have_label);
2490 label = cPVOP->op_pv;
2492 if (label && *label) {
2497 PL_lastgotoprobe = 0;
2499 for (ix = cxstack_ix; ix >= 0; ix--) {
2501 switch (CxTYPE(cx)) {
2503 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2506 gotoprobe = cx->blk_oldcop->op_sibling;
2512 gotoprobe = cx->blk_oldcop->op_sibling;
2514 gotoprobe = PL_main_root;
2517 if (CvDEPTH(cx->blk_sub.cv)) {
2518 gotoprobe = CvROOT(cx->blk_sub.cv);
2524 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2527 DIE(aTHX_ "panic: goto");
2528 gotoprobe = PL_main_root;
2532 retop = dofindlabel(gotoprobe, label,
2533 enterops, enterops + GOTO_DEPTH);
2537 PL_lastgotoprobe = gotoprobe;
2540 DIE(aTHX_ "Can't find label %s", label);
2542 /* pop unwanted frames */
2544 if (ix < cxstack_ix) {
2551 oldsave = PL_scopestack[PL_scopestack_ix];
2552 LEAVE_SCOPE(oldsave);
2555 /* push wanted frames */
2557 if (*enterops && enterops[1]) {
2559 for (ix = 1; enterops[ix]; ix++) {
2560 PL_op = enterops[ix];
2561 /* Eventually we may want to stack the needed arguments
2562 * for each op. For now, we punt on the hard ones. */
2563 if (PL_op->op_type == OP_ENTERITER)
2564 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2565 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2573 if (!retop) retop = PL_main_start;
2575 PL_restartop = retop;
2576 PL_do_undump = TRUE;
2580 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2581 PL_do_undump = FALSE;
2597 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2601 PL_exit_flags |= PERL_EXIT_EXPECTED;
2603 PUSHs(&PL_sv_undef);
2611 NV value = SvNVx(GvSV(cCOP->cop_gv));
2612 register I32 match = I_32(value);
2615 if (((NV)match) > value)
2616 --match; /* was fractional--truncate other way */
2618 match -= cCOP->uop.scop.scop_offset;
2621 else if (match > cCOP->uop.scop.scop_max)
2622 match = cCOP->uop.scop.scop_max;
2623 PL_op = cCOP->uop.scop.scop_next[match];
2633 PL_op = PL_op->op_next; /* can't assume anything */
2636 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2637 match -= cCOP->uop.scop.scop_offset;
2640 else if (match > cCOP->uop.scop.scop_max)
2641 match = cCOP->uop.scop.scop_max;
2642 PL_op = cCOP->uop.scop.scop_next[match];
2651 S_save_lines(pTHX_ AV *array, SV *sv)
2653 register char *s = SvPVX(sv);
2654 register char *send = SvPVX(sv) + SvCUR(sv);
2656 register I32 line = 1;
2658 while (s && s < send) {
2659 SV *tmpstr = NEWSV(85,0);
2661 sv_upgrade(tmpstr, SVt_PVMG);
2662 t = strchr(s, '\n');
2668 sv_setpvn(tmpstr, s, t - s);
2669 av_store(array, line++, tmpstr);
2674 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2676 S_docatch_body(pTHX_ va_list args)
2678 return docatch_body();
2683 S_docatch_body(pTHX)
2690 S_docatch(pTHX_ OP *o)
2694 volatile PERL_SI *cursi = PL_curstackinfo;
2698 assert(CATCH_GET == TRUE);
2701 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2703 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2709 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2715 if (PL_restartop && cursi == PL_curstackinfo) {
2716 PL_op = PL_restartop;
2733 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2734 /* sv Text to convert to OP tree. */
2735 /* startop op_free() this to undo. */
2736 /* code Short string id of the caller. */
2738 dSP; /* Make POPBLOCK work. */
2741 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2745 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2746 char *tmpbuf = tbuf;
2752 /* switch to eval mode */
2754 if (PL_curcop == &PL_compiling) {
2755 SAVECOPSTASH_FREE(&PL_compiling);
2756 CopSTASH_set(&PL_compiling, PL_curstash);
2758 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2759 SV *sv = sv_newmortal();
2760 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2761 code, (unsigned long)++PL_evalseq,
2762 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2766 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2767 SAVECOPFILE_FREE(&PL_compiling);
2768 CopFILE_set(&PL_compiling, tmpbuf+2);
2769 SAVECOPLINE(&PL_compiling);
2770 CopLINE_set(&PL_compiling, 1);
2771 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2772 deleting the eval's FILEGV from the stash before gv_check() runs
2773 (i.e. before run-time proper). To work around the coredump that
2774 ensues, we always turn GvMULTI_on for any globals that were
2775 introduced within evals. See force_ident(). GSAR 96-10-12 */
2776 safestr = savepv(tmpbuf);
2777 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2779 #ifdef OP_IN_REGISTER
2784 PL_hints &= HINT_UTF8;
2787 PL_op->op_type = OP_ENTEREVAL;
2788 PL_op->op_flags = 0; /* Avoid uninit warning. */
2789 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2790 PUSHEVAL(cx, 0, Nullgv);
2791 rop = doeval(G_SCALAR, startop);
2792 POPBLOCK(cx,PL_curpm);
2795 (*startop)->op_type = OP_NULL;
2796 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2798 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2800 if (PL_curcop == &PL_compiling)
2801 PL_compiling.op_private = PL_hints;
2802 #ifdef OP_IN_REGISTER
2808 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2810 S_doeval(pTHX_ int gimme, OP** startop)
2818 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2819 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2824 /* set up a scratch pad */
2827 SAVEVPTR(PL_curpad);
2828 SAVESPTR(PL_comppad);
2829 SAVESPTR(PL_comppad_name);
2830 SAVEI32(PL_comppad_name_fill);
2831 SAVEI32(PL_min_intro_pending);
2832 SAVEI32(PL_max_intro_pending);
2835 for (i = cxstack_ix - 1; i >= 0; i--) {
2836 PERL_CONTEXT *cx = &cxstack[i];
2837 if (CxTYPE(cx) == CXt_EVAL)
2839 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2840 caller = cx->blk_sub.cv;
2845 SAVESPTR(PL_compcv);
2846 PL_compcv = (CV*)NEWSV(1104,0);
2847 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2848 CvEVAL_on(PL_compcv);
2850 CvOWNER(PL_compcv) = 0;
2851 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2852 MUTEX_INIT(CvMUTEXP(PL_compcv));
2853 #endif /* USE_THREADS */
2855 PL_comppad = newAV();
2856 av_push(PL_comppad, Nullsv);
2857 PL_curpad = AvARRAY(PL_comppad);
2858 PL_comppad_name = newAV();
2859 PL_comppad_name_fill = 0;
2860 PL_min_intro_pending = 0;
2863 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2864 PL_curpad[0] = (SV*)newAV();
2865 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2866 #endif /* USE_THREADS */
2868 comppadlist = newAV();
2869 AvREAL_off(comppadlist);
2870 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2871 av_store(comppadlist, 1, (SV*)PL_comppad);
2872 CvPADLIST(PL_compcv) = comppadlist;
2875 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2877 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2880 SAVEFREESV(PL_compcv);
2882 /* make sure we compile in the right package */
2884 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2885 SAVESPTR(PL_curstash);
2886 PL_curstash = CopSTASH(PL_curcop);
2888 SAVESPTR(PL_beginav);
2889 PL_beginav = newAV();
2890 SAVEFREESV(PL_beginav);
2891 SAVEI32(PL_error_count);
2893 /* try to compile it */
2895 PL_eval_root = Nullop;
2897 PL_curcop = &PL_compiling;
2898 PL_curcop->cop_arybase = 0;
2899 SvREFCNT_dec(PL_rs);
2900 PL_rs = newSVpvn("\n", 1);
2901 if (saveop && saveop->op_flags & OPf_SPECIAL)
2902 PL_in_eval |= EVAL_KEEPERR;
2905 if (yyparse() || PL_error_count || !PL_eval_root) {
2909 I32 optype = 0; /* Might be reset by POPEVAL. */
2914 op_free(PL_eval_root);
2915 PL_eval_root = Nullop;
2917 SP = PL_stack_base + POPMARK; /* pop original mark */
2919 POPBLOCK(cx,PL_curpm);
2925 if (optype == OP_REQUIRE) {
2926 char* msg = SvPVx(ERRSV, n_a);
2927 DIE(aTHX_ "%sCompilation failed in require",
2928 *msg ? msg : "Unknown error\n");
2931 char* msg = SvPVx(ERRSV, n_a);
2933 POPBLOCK(cx,PL_curpm);
2935 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2936 (*msg ? msg : "Unknown error\n"));
2938 SvREFCNT_dec(PL_rs);
2939 PL_rs = SvREFCNT_inc(PL_nrs);
2941 MUTEX_LOCK(&PL_eval_mutex);
2943 COND_SIGNAL(&PL_eval_cond);
2944 MUTEX_UNLOCK(&PL_eval_mutex);
2945 #endif /* USE_THREADS */
2948 SvREFCNT_dec(PL_rs);
2949 PL_rs = SvREFCNT_inc(PL_nrs);
2950 CopLINE_set(&PL_compiling, 0);
2952 *startop = PL_eval_root;
2953 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2954 CvOUTSIDE(PL_compcv) = Nullcv;
2956 SAVEFREEOP(PL_eval_root);
2958 scalarvoid(PL_eval_root);
2959 else if (gimme & G_ARRAY)
2962 scalar(PL_eval_root);
2964 DEBUG_x(dump_eval());
2966 /* Register with debugger: */
2967 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2968 CV *cv = get_cv("DB::postponed", FALSE);
2972 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2974 call_sv((SV*)cv, G_DISCARD);
2978 /* compiled okay, so do it */
2980 CvDEPTH(PL_compcv) = 1;
2981 SP = PL_stack_base + POPMARK; /* pop original mark */
2982 PL_op = saveop; /* The caller may need it. */
2983 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2985 MUTEX_LOCK(&PL_eval_mutex);
2987 COND_SIGNAL(&PL_eval_cond);
2988 MUTEX_UNLOCK(&PL_eval_mutex);
2989 #endif /* USE_THREADS */
2991 RETURNOP(PL_eval_start);
2995 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2997 STRLEN namelen = strlen(name);
3000 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3001 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3002 char *pmc = SvPV_nolen(pmcsv);
3005 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3006 fp = PerlIO_open(name, mode);
3009 if (PerlLIO_stat(name, &pmstat) < 0 ||
3010 pmstat.st_mtime < pmcstat.st_mtime)
3012 fp = PerlIO_open(pmc, mode);
3015 fp = PerlIO_open(name, mode);
3018 SvREFCNT_dec(pmcsv);
3021 fp = PerlIO_open(name, mode);
3029 register PERL_CONTEXT *cx;
3034 SV *namesv = Nullsv;
3036 I32 gimme = G_SCALAR;
3037 PerlIO *tryrsfp = 0;
3039 int filter_has_file = 0;
3040 GV *filter_child_proc = 0;
3041 SV *filter_state = 0;
3046 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3047 UV rev = 0, ver = 0, sver = 0;
3049 U8 *s = (U8*)SvPVX(sv);
3050 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3052 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3055 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3058 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3061 if (PERL_REVISION < rev
3062 || (PERL_REVISION == rev
3063 && (PERL_VERSION < ver
3064 || (PERL_VERSION == ver
3065 && PERL_SUBVERSION < sver))))
3067 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3068 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3069 PERL_VERSION, PERL_SUBVERSION);
3073 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3074 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3075 + ((NV)PERL_SUBVERSION/(NV)1000000)
3076 + 0.00000099 < SvNV(sv))
3080 NV nver = (nrev - rev) * 1000;
3081 UV ver = (UV)(nver + 0.0009);
3082 NV nsver = (nver - ver) * 1000;
3083 UV sver = (UV)(nsver + 0.0009);
3085 /* help out with the "use 5.6" confusion */
3086 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3087 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3088 "this is only v%d.%d.%d, stopped"
3089 " (did you mean v%"UVuf".%"UVuf".0?)",
3090 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3091 PERL_SUBVERSION, rev, ver/100);
3094 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3095 "this is only v%d.%d.%d, stopped",
3096 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3103 name = SvPV(sv, len);
3104 if (!(name && len > 0 && *name))
3105 DIE(aTHX_ "Null filename used");
3106 TAINT_PROPER("require");
3107 if (PL_op->op_type == OP_REQUIRE &&
3108 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3109 *svp != &PL_sv_undef)
3112 /* prepare to compile file */
3114 #ifdef MACOS_TRADITIONAL
3115 if (PERL_FILE_IS_ABSOLUTE(name)
3116 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3119 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3120 /* We consider paths of the form :a:b ambiguous and interpret them first
3121 as global then as local
3123 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3129 if (PERL_FILE_IS_ABSOLUTE(name)
3130 || (*name == '.' && (name[1] == '/' ||
3131 (name[1] == '.' && name[2] == '/'))))
3134 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3138 AV *ar = GvAVn(PL_incgv);
3142 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3145 namesv = NEWSV(806, 0);
3146 for (i = 0; i <= AvFILL(ar); i++) {
3147 SV *dirsv = *av_fetch(ar, i, TRUE);
3153 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3154 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3157 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3158 PTR2UV(SvANY(loader)), name);
3159 tryname = SvPVX(namesv);
3170 if (sv_isobject(loader))
3171 count = call_method("INC", G_ARRAY);
3173 count = call_sv(loader, G_ARRAY);
3183 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3187 if (SvTYPE(arg) == SVt_PVGV) {
3188 IO *io = GvIO((GV *)arg);
3193 tryrsfp = IoIFP(io);
3194 if (IoTYPE(io) == IoTYPE_PIPE) {
3195 /* reading from a child process doesn't
3196 nest -- when returning from reading
3197 the inner module, the outer one is
3198 unreadable (closed?) I've tried to
3199 save the gv to manage the lifespan of
3200 the pipe, but this didn't help. XXX */
3201 filter_child_proc = (GV *)arg;
3202 (void)SvREFCNT_inc(filter_child_proc);
3205 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3206 PerlIO_close(IoOFP(io));
3218 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3220 (void)SvREFCNT_inc(filter_sub);
3223 filter_state = SP[i];
3224 (void)SvREFCNT_inc(filter_state);
3228 tryrsfp = PerlIO_open("/dev/null",
3242 filter_has_file = 0;
3243 if (filter_child_proc) {
3244 SvREFCNT_dec(filter_child_proc);
3245 filter_child_proc = 0;
3248 SvREFCNT_dec(filter_state);
3252 SvREFCNT_dec(filter_sub);
3257 char *dir = SvPVx(dirsv, n_a);
3258 #ifdef MACOS_TRADITIONAL
3260 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3264 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3266 sv_setpv(namesv, unixdir);
3267 sv_catpv(namesv, unixname);
3269 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3272 TAINT_PROPER("require");
3273 tryname = SvPVX(namesv);
3274 #ifdef MACOS_TRADITIONAL
3276 /* Convert slashes in the name part, but not the directory part, to colons */
3278 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3282 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3284 if (tryname[0] == '.' && tryname[1] == '/')
3292 SAVECOPFILE_FREE(&PL_compiling);
3293 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3294 SvREFCNT_dec(namesv);
3296 if (PL_op->op_type == OP_REQUIRE) {
3297 char *msgstr = name;
3298 if (namesv) { /* did we lookup @INC? */
3299 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3300 SV *dirmsgsv = NEWSV(0, 0);
3301 AV *ar = GvAVn(PL_incgv);
3303 sv_catpvn(msg, " in @INC", 8);
3304 if (instr(SvPVX(msg), ".h "))
3305 sv_catpv(msg, " (change .h to .ph maybe?)");
3306 if (instr(SvPVX(msg), ".ph "))
3307 sv_catpv(msg, " (did you run h2ph?)");
3308 sv_catpv(msg, " (@INC contains:");
3309 for (i = 0; i <= AvFILL(ar); i++) {
3310 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3311 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3312 sv_catsv(msg, dirmsgsv);
3314 sv_catpvn(msg, ")", 1);
3315 SvREFCNT_dec(dirmsgsv);
3316 msgstr = SvPV_nolen(msg);
3318 DIE(aTHX_ "Can't locate %s", msgstr);
3324 SETERRNO(0, SS$_NORMAL);
3326 /* Assume success here to prevent recursive requirement. */
3327 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3328 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3332 lex_start(sv_2mortal(newSVpvn("",0)));
3333 SAVEGENERICSV(PL_rsfp_filters);
3334 PL_rsfp_filters = Nullav;
3339 SAVESPTR(PL_compiling.cop_warnings);
3340 if (PL_dowarn & G_WARN_ALL_ON)
3341 PL_compiling.cop_warnings = pWARN_ALL ;
3342 else if (PL_dowarn & G_WARN_ALL_OFF)
3343 PL_compiling.cop_warnings = pWARN_NONE ;
3345 PL_compiling.cop_warnings = pWARN_STD ;
3346 SAVESPTR(PL_compiling.cop_io);
3347 PL_compiling.cop_io = Nullsv;
3349 if (filter_sub || filter_child_proc) {
3350 SV *datasv = filter_add(run_user_filter, Nullsv);
3351 IoLINES(datasv) = filter_has_file;
3352 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3353 IoTOP_GV(datasv) = (GV *)filter_state;
3354 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3357 /* switch to eval mode */
3358 push_return(PL_op->op_next);
3359 PUSHBLOCK(cx, CXt_EVAL, SP);
3360 PUSHEVAL(cx, name, Nullgv);
3362 SAVECOPLINE(&PL_compiling);
3363 CopLINE_set(&PL_compiling, 0);
3367 MUTEX_LOCK(&PL_eval_mutex);
3368 if (PL_eval_owner && PL_eval_owner != thr)
3369 while (PL_eval_owner)
3370 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3371 PL_eval_owner = thr;
3372 MUTEX_UNLOCK(&PL_eval_mutex);
3373 #endif /* USE_THREADS */
3374 return DOCATCH(doeval(G_SCALAR, NULL));
3379 return pp_require();
3385 register PERL_CONTEXT *cx;
3387 I32 gimme = GIMME_V, was = PL_sub_generation;
3388 char tbuf[TYPE_DIGITS(long) + 12];
3389 char *tmpbuf = tbuf;
3394 if (!SvPV(sv,len) || !len)
3396 TAINT_PROPER("eval");
3402 /* switch to eval mode */
3404 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3405 SV *sv = sv_newmortal();
3406 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3407 (unsigned long)++PL_evalseq,
3408 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3412 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3413 SAVECOPFILE_FREE(&PL_compiling);
3414 CopFILE_set(&PL_compiling, tmpbuf+2);
3415 SAVECOPLINE(&PL_compiling);
3416 CopLINE_set(&PL_compiling, 1);
3417 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3418 deleting the eval's FILEGV from the stash before gv_check() runs
3419 (i.e. before run-time proper). To work around the coredump that
3420 ensues, we always turn GvMULTI_on for any globals that were
3421 introduced within evals. See force_ident(). GSAR 96-10-12 */
3422 safestr = savepv(tmpbuf);
3423 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3425 PL_hints = PL_op->op_targ;
3426 SAVESPTR(PL_compiling.cop_warnings);
3427 if (specialWARN(PL_curcop->cop_warnings))
3428 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3430 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3431 SAVEFREESV(PL_compiling.cop_warnings);
3433 SAVESPTR(PL_compiling.cop_io);
3434 if (specialCopIO(PL_curcop->cop_io))
3435 PL_compiling.cop_io = PL_curcop->cop_io;
3437 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3438 SAVEFREESV(PL_compiling.cop_io);
3441 push_return(PL_op->op_next);
3442 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3443 PUSHEVAL(cx, 0, Nullgv);
3445 /* prepare to compile string */
3447 if (PERLDB_LINE && PL_curstash != PL_debstash)
3448 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3451 MUTEX_LOCK(&PL_eval_mutex);
3452 if (PL_eval_owner && PL_eval_owner != thr)
3453 while (PL_eval_owner)
3454 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3455 PL_eval_owner = thr;
3456 MUTEX_UNLOCK(&PL_eval_mutex);
3457 #endif /* USE_THREADS */
3458 ret = doeval(gimme, NULL);
3459 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3460 && ret != PL_op->op_next) { /* Successive compilation. */
3461 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3463 return DOCATCH(ret);
3473 register PERL_CONTEXT *cx;
3475 U8 save_flags = PL_op -> op_flags;
3480 retop = pop_return();
3483 if (gimme == G_VOID)
3485 else if (gimme == G_SCALAR) {
3488 if (SvFLAGS(TOPs) & SVs_TEMP)
3491 *MARK = sv_mortalcopy(TOPs);
3495 *MARK = &PL_sv_undef;
3500 /* in case LEAVE wipes old return values */
3501 for (mark = newsp + 1; mark <= SP; mark++) {
3502 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3503 *mark = sv_mortalcopy(*mark);
3504 TAINT_NOT; /* Each item is independent */
3508 PL_curpm = newpm; /* Don't pop $1 et al till now */
3510 if (AvFILLp(PL_comppad_name) >= 0)
3514 assert(CvDEPTH(PL_compcv) == 1);
3516 CvDEPTH(PL_compcv) = 0;
3519 if (optype == OP_REQUIRE &&
3520 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3522 /* Unassume the success we assumed earlier. */
3523 SV *nsv = cx->blk_eval.old_namesv;
3524 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3525 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3526 /* die_where() did LEAVE, or we won't be here */
3530 if (!(save_flags & OPf_SPECIAL))
3540 register PERL_CONTEXT *cx;
3541 I32 gimme = GIMME_V;
3546 push_return(cLOGOP->op_other->op_next);
3547 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3549 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3551 PL_in_eval = EVAL_INEVAL;
3554 return DOCATCH(PL_op->op_next);
3564 register PERL_CONTEXT *cx;
3572 if (gimme == G_VOID)
3574 else if (gimme == G_SCALAR) {
3577 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3580 *MARK = sv_mortalcopy(TOPs);
3584 *MARK = &PL_sv_undef;
3589 /* in case LEAVE wipes old return values */
3590 for (mark = newsp + 1; mark <= SP; mark++) {
3591 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3592 *mark = sv_mortalcopy(*mark);
3593 TAINT_NOT; /* Each item is independent */
3597 PL_curpm = newpm; /* Don't pop $1 et al till now */
3605 S_doparseform(pTHX_ SV *sv)
3608 register char *s = SvPV_force(sv, len);
3609 register char *send = s + len;
3610 register char *base;
3611 register I32 skipspaces = 0;
3614 bool postspace = FALSE;
3622 Perl_croak(aTHX_ "Null picture in formline");
3624 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3629 *fpc++ = FF_LINEMARK;
3630 noblank = repeat = FALSE;
3648 case ' ': case '\t':
3659 *fpc++ = FF_LITERAL;
3667 *fpc++ = skipspaces;
3671 *fpc++ = FF_NEWLINE;
3675 arg = fpc - linepc + 1;
3682 *fpc++ = FF_LINEMARK;
3683 noblank = repeat = FALSE;
3692 ischop = s[-1] == '^';
3698 arg = (s - base) - 1;
3700 *fpc++ = FF_LITERAL;
3709 *fpc++ = FF_LINEGLOB;
3711 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3712 arg = ischop ? 512 : 0;
3722 arg |= 256 + (s - f);
3724 *fpc++ = s - base; /* fieldsize for FETCH */
3725 *fpc++ = FF_DECIMAL;
3728 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3729 arg = ischop ? 512 : 0;
3731 s++; /* skip the '0' first */
3740 arg |= 256 + (s - f);
3742 *fpc++ = s - base; /* fieldsize for FETCH */
3743 *fpc++ = FF_0DECIMAL;
3748 bool ismore = FALSE;
3751 while (*++s == '>') ;
3752 prespace = FF_SPACE;
3754 else if (*s == '|') {
3755 while (*++s == '|') ;
3756 prespace = FF_HALFSPACE;
3761 while (*++s == '<') ;
3764 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3768 *fpc++ = s - base; /* fieldsize for FETCH */
3770 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3788 { /* need to jump to the next word */
3790 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3791 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3792 s = SvPVX(sv) + SvCUR(sv) + z;
3794 Copy(fops, s, arg, U16);
3796 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3801 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3803 * The original code was written in conjunction with BSD Computer Software
3804 * Research Group at University of California, Berkeley.
3806 * See also: "Optimistic Merge Sort" (SODA '92)
3808 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3810 * The code can be distributed under the same terms as Perl itself.
3815 #include <sys/types.h>
3820 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3821 #define Safefree(VAR) free(VAR)
3822 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3823 #endif /* TESTHARNESS */
3825 typedef char * aptr; /* pointer for arithmetic on sizes */
3826 typedef SV * gptr; /* pointers in our lists */
3828 /* Binary merge internal sort, with a few special mods
3829 ** for the special perl environment it now finds itself in.
3831 ** Things that were once options have been hotwired
3832 ** to values suitable for this use. In particular, we'll always
3833 ** initialize looking for natural runs, we'll always produce stable
3834 ** output, and we'll always do Peter McIlroy's binary merge.
3837 /* Pointer types for arithmetic and storage and convenience casts */
3839 #define APTR(P) ((aptr)(P))
3840 #define GPTP(P) ((gptr *)(P))
3841 #define GPPP(P) ((gptr **)(P))
3844 /* byte offset from pointer P to (larger) pointer Q */
3845 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3847 #define PSIZE sizeof(gptr)
3849 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3852 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3853 #define PNBYTE(N) ((N) << (PSHIFT))
3854 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3856 /* Leave optimization to compiler */
3857 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3858 #define PNBYTE(N) ((N) * (PSIZE))
3859 #define PINDEX(P, N) (GPTP(P) + (N))
3862 /* Pointer into other corresponding to pointer into this */
3863 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3865 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3868 /* Runs are identified by a pointer in the auxilliary list.
3869 ** The pointer is at the start of the list,
3870 ** and it points to the start of the next list.
3871 ** NEXT is used as an lvalue, too.
3874 #define NEXT(P) (*GPPP(P))
3877 /* PTHRESH is the minimum number of pairs with the same sense to justify
3878 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3879 ** not just elements, so PTHRESH == 8 means a run of 16.
3884 /* RTHRESH is the number of elements in a run that must compare low
3885 ** to the low element from the opposing run before we justify
3886 ** doing a binary rampup instead of single stepping.
3887 ** In random input, N in a row low should only happen with
3888 ** probability 2^(1-N), so we can risk that we are dealing
3889 ** with orderly input without paying much when we aren't.
3896 ** Overview of algorithm and variables.
3897 ** The array of elements at list1 will be organized into runs of length 2,
3898 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3899 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3901 ** Unless otherwise specified, pair pointers address the first of two elements.
3903 ** b and b+1 are a pair that compare with sense ``sense''.
3904 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3906 ** p2 parallels b in the list2 array, where runs are defined by
3909 ** t represents the ``top'' of the adjacent pairs that might extend
3910 ** the run beginning at b. Usually, t addresses a pair
3911 ** that compares with opposite sense from (b,b+1).
3912 ** However, it may also address a singleton element at the end of list1,
3913 ** or it may be equal to ``last'', the first element beyond list1.
3915 ** r addresses the Nth pair following b. If this would be beyond t,
3916 ** we back it off to t. Only when r is less than t do we consider the
3917 ** run long enough to consider checking.
3919 ** q addresses a pair such that the pairs at b through q already form a run.
3920 ** Often, q will equal b, indicating we only are sure of the pair itself.
3921 ** However, a search on the previous cycle may have revealed a longer run,
3922 ** so q may be greater than b.
3924 ** p is used to work back from a candidate r, trying to reach q,
3925 ** which would mean b through r would be a run. If we discover such a run,
3926 ** we start q at r and try to push it further towards t.
3927 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3928 ** In any event, after the check (if any), we have two main cases.
3930 ** 1) Short run. b <= q < p <= r <= t.
3931 ** b through q is a run (perhaps trivial)
3932 ** q through p are uninteresting pairs
3933 ** p through r is a run
3935 ** 2) Long run. b < r <= q < t.
3936 ** b through q is a run (of length >= 2 * PTHRESH)
3938 ** Note that degenerate cases are not only possible, but likely.
3939 ** For example, if the pair following b compares with opposite sense,
3940 ** then b == q < p == r == t.
3945 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3948 register gptr *b, *p, *q, *t, *p2;
3949 register gptr c, *last, *r;
3953 last = PINDEX(b, nmemb);
3954 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3955 for (p2 = list2; b < last; ) {
3956 /* We just started, or just reversed sense.
3957 ** Set t at end of pairs with the prevailing sense.
3959 for (p = b+2, t = p; ++p < last; t = ++p) {
3960 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3963 /* Having laid out the playing field, look for long runs */
3965 p = r = b + (2 * PTHRESH);
3966 if (r >= t) p = r = t; /* too short to care about */
3968 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3971 /* b through r is a (long) run.
3972 ** Extend it as far as possible.
3975 while (((p += 2) < t) &&
3976 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3977 r = p = q + 2; /* no simple pairs, no after-run */
3980 if (q > b) { /* run of greater than 2 at b */
3983 /* pick up singleton, if possible */
3985 ((t + 1) == last) &&
3986 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3987 savep = r = p = q = last;
3988 p2 = NEXT(p2) = p2 + (p - b);
3989 if (sense) while (b < --p) {
3996 while (q < p) { /* simple pairs */
3997 p2 = NEXT(p2) = p2 + 2;
4004 if (((b = p) == t) && ((t+1) == last)) {
4016 /* Overview of bmerge variables:
4018 ** list1 and list2 address the main and auxiliary arrays.
4019 ** They swap identities after each merge pass.
4020 ** Base points to the original list1, so we can tell if
4021 ** the pointers ended up where they belonged (or must be copied).
4023 ** When we are merging two lists, f1 and f2 are the next elements
4024 ** on the respective lists. l1 and l2 mark the end of the lists.
4025 ** tp2 is the current location in the merged list.
4027 ** p1 records where f1 started.
4028 ** After the merge, a new descriptor is built there.
4030 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4031 ** It is used to identify and delimit the runs.
4033 ** In the heat of determining where q, the greater of the f1/f2 elements,
4034 ** belongs in the other list, b, t and p, represent bottom, top and probe
4035 ** locations, respectively, in the other list.
4036 ** They make convenient temporary pointers in other places.
4040 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4044 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4045 gptr *aux, *list2, *p2, *last;
4049 if (nmemb <= 1) return; /* sorted trivially */
4050 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4052 dynprep(aTHX_ list1, list2, nmemb, cmp);
4053 last = PINDEX(list2, nmemb);
4054 while (NEXT(list2) != last) {
4055 /* More than one run remains. Do some merging to reduce runs. */
4057 for (tp2 = p2 = list2; p2 != last;) {
4058 /* The new first run begins where the old second list ended.
4059 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4063 f2 = l1 = POTHER(t, list2, list1);
4064 if (t != last) t = NEXT(t);
4065 l2 = POTHER(t, list2, list1);
4067 while (f1 < l1 && f2 < l2) {
4068 /* If head 1 is larger than head 2, find ALL the elements
4069 ** in list 2 strictly less than head1, write them all,
4070 ** then head 1. Then compare the new heads, and repeat,
4071 ** until one or both lists are exhausted.
4073 ** In all comparisons (after establishing
4074 ** which head to merge) the item to merge
4075 ** (at pointer q) is the first operand of
4076 ** the comparison. When we want to know
4077 ** if ``q is strictly less than the other'',
4079 ** cmp(q, other) < 0
4080 ** because stability demands that we treat equality
4081 ** as high when q comes from l2, and as low when
4082 ** q was from l1. So we ask the question by doing
4083 ** cmp(q, other) <= sense
4084 ** and make sense == 0 when equality should look low,
4085 ** and -1 when equality should look high.
4089 if (cmp(aTHX_ *f1, *f2) <= 0) {
4090 q = f2; b = f1; t = l1;
4093 q = f1; b = f2; t = l2;
4100 ** Leave t at something strictly
4101 ** greater than q (or at the end of the list),
4102 ** and b at something strictly less than q.
4104 for (i = 1, run = 0 ;;) {
4105 if ((p = PINDEX(b, i)) >= t) {
4107 if (((p = PINDEX(t, -1)) > b) &&
4108 (cmp(aTHX_ *q, *p) <= sense))
4112 } else if (cmp(aTHX_ *q, *p) <= sense) {
4116 if (++run >= RTHRESH) i += i;
4120 /* q is known to follow b and must be inserted before t.
4121 ** Increment b, so the range of possibilities is [b,t).
4122 ** Round binary split down, to favor early appearance.
4123 ** Adjust b and t until q belongs just before t.
4128 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4129 if (cmp(aTHX_ *q, *p) <= sense) {
4135 /* Copy all the strictly low elements */
4138 FROMTOUPTO(f2, tp2, t);
4141 FROMTOUPTO(f1, tp2, t);
4147 /* Run out remaining list */
4149 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4150 } else FROMTOUPTO(f1, tp2, l1);
4151 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4156 last = PINDEX(list2, nmemb);
4158 if (base == list2) {
4159 last = PINDEX(list1, nmemb);
4160 FROMTOUPTO(list1, list2, last);
4175 sortcv(pTHXo_ SV *a, SV *b)
4177 I32 oldsaveix = PL_savestack_ix;
4178 I32 oldscopeix = PL_scopestack_ix;
4180 GvSV(PL_firstgv) = a;
4181 GvSV(PL_secondgv) = b;
4182 PL_stack_sp = PL_stack_base;
4185 if (PL_stack_sp != PL_stack_base + 1)
4186 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4187 if (!SvNIOKp(*PL_stack_sp))
4188 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4189 result = SvIV(*PL_stack_sp);
4190 while (PL_scopestack_ix > oldscopeix) {
4193 leave_scope(oldsaveix);
4198 sortcv_stacked(pTHXo_ SV *a, SV *b)
4200 I32 oldsaveix = PL_savestack_ix;
4201 I32 oldscopeix = PL_scopestack_ix;
4206 av = (AV*)PL_curpad[0];
4208 av = GvAV(PL_defgv);
4211 if (AvMAX(av) < 1) {
4212 SV** ary = AvALLOC(av);
4213 if (AvARRAY(av) != ary) {
4214 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4215 SvPVX(av) = (char*)ary;
4217 if (AvMAX(av) < 1) {
4220 SvPVX(av) = (char*)ary;
4227 PL_stack_sp = PL_stack_base;
4230 if (PL_stack_sp != PL_stack_base + 1)
4231 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4232 if (!SvNIOKp(*PL_stack_sp))
4233 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4234 result = SvIV(*PL_stack_sp);
4235 while (PL_scopestack_ix > oldscopeix) {
4238 leave_scope(oldsaveix);
4243 sortcv_xsub(pTHXo_ SV *a, SV *b)
4246 I32 oldsaveix = PL_savestack_ix;
4247 I32 oldscopeix = PL_scopestack_ix;
4249 CV *cv=(CV*)PL_sortcop;
4257 (void)(*CvXSUB(cv))(aTHXo_ cv);
4258 if (PL_stack_sp != PL_stack_base + 1)
4259 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4260 if (!SvNIOKp(*PL_stack_sp))
4261 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4262 result = SvIV(*PL_stack_sp);
4263 while (PL_scopestack_ix > oldscopeix) {
4266 leave_scope(oldsaveix);
4272 sv_ncmp(pTHXo_ SV *a, SV *b)
4276 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4280 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4284 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4286 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4288 if (PL_amagic_generation) { \
4289 if (SvAMAGIC(left)||SvAMAGIC(right))\
4290 *svp = amagic_call(left, \
4298 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4301 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4306 I32 i = SvIVX(tmpsv);
4316 return sv_ncmp(aTHXo_ a, b);
4320 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4323 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4328 I32 i = SvIVX(tmpsv);
4338 return sv_i_ncmp(aTHXo_ a, b);
4342 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4345 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4350 I32 i = SvIVX(tmpsv);
4360 return sv_cmp(str1, str2);
4364 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4367 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4372 I32 i = SvIVX(tmpsv);
4382 return sv_cmp_locale(str1, str2);
4386 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4388 SV *datasv = FILTER_DATA(idx);
4389 int filter_has_file = IoLINES(datasv);
4390 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4391 SV *filter_state = (SV *)IoTOP_GV(datasv);
4392 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4395 /* I was having segfault trouble under Linux 2.2.5 after a
4396 parse error occured. (Had to hack around it with a test
4397 for PL_error_count == 0.) Solaris doesn't segfault --
4398 not sure where the trouble is yet. XXX */
4400 if (filter_has_file) {
4401 len = FILTER_READ(idx+1, buf_sv, maxlen);
4404 if (filter_sub && len >= 0) {
4415 PUSHs(sv_2mortal(newSViv(maxlen)));
4417 PUSHs(filter_state);
4420 count = call_sv(filter_sub, G_SCALAR);
4436 IoLINES(datasv) = 0;
4437 if (filter_child_proc) {
4438 SvREFCNT_dec(filter_child_proc);
4439 IoFMT_GV(datasv) = Nullgv;
4442 SvREFCNT_dec(filter_state);
4443 IoTOP_GV(datasv) = Nullgv;
4446 SvREFCNT_dec(filter_sub);
4447 IoBOTTOM_GV(datasv) = Nullgv;
4449 filter_del(run_user_filter);
4458 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4460 return sv_cmp_locale(str1, str2);
4464 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4466 return sv_cmp(str1, str2);
4469 #endif /* PERL_OBJECT */