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 Perl_qerror(pTHX_ SV *err)
1387 sv_catsv(ERRSV, err);
1389 sv_catsv(PL_errors, err);
1391 Perl_warn(aTHX_ "%"SVf, err);
1396 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1401 register PERL_CONTEXT *cx;
1406 if (PL_in_eval & EVAL_KEEPERR) {
1407 static char prefix[] = "\t(in cleanup) ";
1412 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1415 if (*e != *message || strNE(e,message))
1419 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1420 sv_catpvn(err, prefix, sizeof(prefix)-1);
1421 sv_catpvn(err, message, msglen);
1422 if (ckWARN(WARN_MISC)) {
1423 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1424 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1429 sv_setpvn(ERRSV, message, msglen);
1430 if (PL_hints & HINT_UTF8)
1437 message = SvPVx(ERRSV, msglen);
1439 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1440 && PL_curstackinfo->si_prev)
1449 if (cxix < cxstack_ix)
1452 POPBLOCK(cx,PL_curpm);
1453 if (CxTYPE(cx) != CXt_EVAL) {
1454 PerlIO_write(Perl_error_log, "panic: die ", 11);
1455 PerlIO_write(Perl_error_log, message, msglen);
1460 if (gimme == G_SCALAR)
1461 *++newsp = &PL_sv_undef;
1462 PL_stack_sp = newsp;
1466 /* LEAVE could clobber PL_curcop (see save_re_context())
1467 * XXX it might be better to find a way to avoid messing with
1468 * PL_curcop in save_re_context() instead, but this is a more
1469 * minimal fix --GSAR */
1470 PL_curcop = cx->blk_oldcop;
1472 if (optype == OP_REQUIRE) {
1473 char* msg = SvPVx(ERRSV, n_a);
1474 DIE(aTHX_ "%sCompilation failed in require",
1475 *msg ? msg : "Unknown error\n");
1477 return pop_return();
1481 message = SvPVx(ERRSV, msglen);
1484 /* SFIO can really mess with your errno */
1487 PerlIO *serr = Perl_error_log;
1489 PerlIO_write(serr, message, msglen);
1490 (void)PerlIO_flush(serr);
1503 if (SvTRUE(left) != SvTRUE(right))
1515 RETURNOP(cLOGOP->op_other);
1524 RETURNOP(cLOGOP->op_other);
1530 register I32 cxix = dopoptosub(cxstack_ix);
1531 register PERL_CONTEXT *cx;
1532 register PERL_CONTEXT *ccstack = cxstack;
1533 PERL_SI *top_si = PL_curstackinfo;
1544 /* we may be in a higher stacklevel, so dig down deeper */
1545 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1546 top_si = top_si->si_prev;
1547 ccstack = top_si->si_cxstack;
1548 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1551 if (GIMME != G_ARRAY)
1555 if (PL_DBsub && cxix >= 0 &&
1556 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1560 cxix = dopoptosub_at(ccstack, cxix - 1);
1563 cx = &ccstack[cxix];
1564 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1565 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1566 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1567 field below is defined for any cx. */
1568 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1569 cx = &ccstack[dbcxix];
1572 stashname = CopSTASHPV(cx->blk_oldcop);
1573 if (GIMME != G_ARRAY) {
1575 PUSHs(&PL_sv_undef);
1578 sv_setpv(TARG, stashname);
1585 PUSHs(&PL_sv_undef);
1587 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1588 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1589 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1592 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1593 /* So is ccstack[dbcxix]. */
1595 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1596 PUSHs(sv_2mortal(sv));
1597 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1600 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1601 PUSHs(sv_2mortal(newSViv(0)));
1603 gimme = (I32)cx->blk_gimme;
1604 if (gimme == G_VOID)
1605 PUSHs(&PL_sv_undef);
1607 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1608 if (CxTYPE(cx) == CXt_EVAL) {
1610 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1611 PUSHs(cx->blk_eval.cur_text);
1615 else if (cx->blk_eval.old_namesv) {
1616 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1619 /* eval BLOCK (try blocks have old_namesv == 0) */
1621 PUSHs(&PL_sv_undef);
1622 PUSHs(&PL_sv_undef);
1626 PUSHs(&PL_sv_undef);
1627 PUSHs(&PL_sv_undef);
1629 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1630 && CopSTASH_eq(PL_curcop, PL_debstash))
1632 AV *ary = cx->blk_sub.argarray;
1633 int off = AvARRAY(ary) - AvALLOC(ary);
1637 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1640 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1643 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1644 av_extend(PL_dbargs, AvFILLp(ary) + off);
1645 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1646 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1648 /* XXX only hints propagated via op_private are currently
1649 * visible (others are not easily accessible, since they
1650 * use the global PL_hints) */
1651 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1652 HINT_PRIVATE_MASK)));
1655 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1657 if (old_warnings == pWARN_NONE ||
1658 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1659 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1660 else if (old_warnings == pWARN_ALL ||
1661 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1662 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1664 mask = newSVsv(old_warnings);
1665 PUSHs(sv_2mortal(mask));
1680 sv_reset(tmps, CopSTASH(PL_curcop));
1692 PL_curcop = (COP*)PL_op;
1693 TAINT_NOT; /* Each statement is presumed innocent */
1694 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1697 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1701 register PERL_CONTEXT *cx;
1702 I32 gimme = G_ARRAY;
1709 DIE(aTHX_ "No DB::DB routine defined");
1711 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1712 /* don't do recursive DB::DB call */
1724 push_return(PL_op->op_next);
1725 PUSHBLOCK(cx, CXt_SUB, SP);
1728 (void)SvREFCNT_inc(cv);
1729 SAVEVPTR(PL_curpad);
1730 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1731 RETURNOP(CvSTART(cv));
1745 register PERL_CONTEXT *cx;
1746 I32 gimme = GIMME_V;
1748 U32 cxtype = CXt_LOOP;
1757 if (PL_op->op_flags & OPf_SPECIAL) {
1758 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1759 SAVEGENERICSV(*svp);
1763 #endif /* USE_THREADS */
1764 if (PL_op->op_targ) {
1765 #ifndef USE_ITHREADS
1766 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1769 SAVEPADSV(PL_op->op_targ);
1770 iterdata = (void*)PL_op->op_targ;
1771 cxtype |= CXp_PADVAR;
1776 svp = &GvSV(gv); /* symbol table variable */
1777 SAVEGENERICSV(*svp);
1780 iterdata = (void*)gv;
1786 PUSHBLOCK(cx, cxtype, SP);
1788 PUSHLOOP(cx, iterdata, MARK);
1790 PUSHLOOP(cx, svp, MARK);
1792 if (PL_op->op_flags & OPf_STACKED) {
1793 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1794 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1796 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1797 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1798 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1799 looks_like_number((SV*)cx->blk_loop.iterary) &&
1800 *SvPVX(cx->blk_loop.iterary) != '0'))
1802 if (SvNV(sv) < IV_MIN ||
1803 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1804 DIE(aTHX_ "Range iterator outside integer range");
1805 cx->blk_loop.iterix = SvIV(sv);
1806 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1809 cx->blk_loop.iterlval = newSVsv(sv);
1813 cx->blk_loop.iterary = PL_curstack;
1814 AvFILLp(PL_curstack) = SP - PL_stack_base;
1815 cx->blk_loop.iterix = MARK - PL_stack_base;
1824 register PERL_CONTEXT *cx;
1825 I32 gimme = GIMME_V;
1831 PUSHBLOCK(cx, CXt_LOOP, SP);
1832 PUSHLOOP(cx, 0, SP);
1840 register PERL_CONTEXT *cx;
1848 newsp = PL_stack_base + cx->blk_loop.resetsp;
1851 if (gimme == G_VOID)
1853 else if (gimme == G_SCALAR) {
1855 *++newsp = sv_mortalcopy(*SP);
1857 *++newsp = &PL_sv_undef;
1861 *++newsp = sv_mortalcopy(*++mark);
1862 TAINT_NOT; /* Each item is independent */
1868 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1869 PL_curpm = newpm; /* ... and pop $1 et al */
1881 register PERL_CONTEXT *cx;
1882 bool popsub2 = FALSE;
1883 bool clear_errsv = FALSE;
1890 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1891 if (cxstack_ix == PL_sortcxix
1892 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1894 if (cxstack_ix > PL_sortcxix)
1895 dounwind(PL_sortcxix);
1896 AvARRAY(PL_curstack)[1] = *SP;
1897 PL_stack_sp = PL_stack_base + 1;
1902 cxix = dopoptosub(cxstack_ix);
1904 DIE(aTHX_ "Can't return outside a subroutine");
1905 if (cxix < cxstack_ix)
1909 switch (CxTYPE(cx)) {
1914 if (!(PL_in_eval & EVAL_KEEPERR))
1920 if (optype == OP_REQUIRE &&
1921 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1923 /* Unassume the success we assumed earlier. */
1924 SV *nsv = cx->blk_eval.old_namesv;
1925 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1926 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1933 DIE(aTHX_ "panic: return");
1937 if (gimme == G_SCALAR) {
1940 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1942 *++newsp = SvREFCNT_inc(*SP);
1947 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1949 *++newsp = sv_mortalcopy(sv);
1954 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1957 *++newsp = sv_mortalcopy(*SP);
1960 *++newsp = &PL_sv_undef;
1962 else if (gimme == G_ARRAY) {
1963 while (++MARK <= SP) {
1964 *++newsp = (popsub2 && SvTEMP(*MARK))
1965 ? *MARK : sv_mortalcopy(*MARK);
1966 TAINT_NOT; /* Each item is independent */
1969 PL_stack_sp = newsp;
1971 /* Stack values are safe: */
1973 POPSUB(cx,sv); /* release CV and @_ ... */
1977 PL_curpm = newpm; /* ... and pop $1 et al */
1983 return pop_return();
1990 register PERL_CONTEXT *cx;
2000 if (PL_op->op_flags & OPf_SPECIAL) {
2001 cxix = dopoptoloop(cxstack_ix);
2003 DIE(aTHX_ "Can't \"last\" outside a loop block");
2006 cxix = dopoptolabel(cPVOP->op_pv);
2008 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2010 if (cxix < cxstack_ix)
2015 switch (CxTYPE(cx)) {
2018 newsp = PL_stack_base + cx->blk_loop.resetsp;
2019 nextop = cx->blk_loop.last_op->op_next;
2023 nextop = pop_return();
2027 nextop = pop_return();
2031 nextop = pop_return();
2034 DIE(aTHX_ "panic: last");
2038 if (gimme == G_SCALAR) {
2040 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2041 ? *SP : sv_mortalcopy(*SP);
2043 *++newsp = &PL_sv_undef;
2045 else if (gimme == G_ARRAY) {
2046 while (++MARK <= SP) {
2047 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2048 ? *MARK : sv_mortalcopy(*MARK);
2049 TAINT_NOT; /* Each item is independent */
2055 /* Stack values are safe: */
2058 POPLOOP(cx); /* release loop vars ... */
2062 POPSUB(cx,sv); /* release CV and @_ ... */
2065 PL_curpm = newpm; /* ... and pop $1 et al */
2075 register PERL_CONTEXT *cx;
2078 if (PL_op->op_flags & OPf_SPECIAL) {
2079 cxix = dopoptoloop(cxstack_ix);
2081 DIE(aTHX_ "Can't \"next\" outside a loop block");
2084 cxix = dopoptolabel(cPVOP->op_pv);
2086 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2088 if (cxix < cxstack_ix)
2091 /* clear off anything above the scope we're re-entering, but
2092 * save the rest until after a possible continue block */
2093 inner = PL_scopestack_ix;
2095 if (PL_scopestack_ix < inner)
2096 leave_scope(PL_scopestack[PL_scopestack_ix]);
2097 return cx->blk_loop.next_op;
2103 register PERL_CONTEXT *cx;
2106 if (PL_op->op_flags & OPf_SPECIAL) {
2107 cxix = dopoptoloop(cxstack_ix);
2109 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2112 cxix = dopoptolabel(cPVOP->op_pv);
2114 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2116 if (cxix < cxstack_ix)
2120 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2121 LEAVE_SCOPE(oldsave);
2122 return cx->blk_loop.redo_op;
2126 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2130 static char too_deep[] = "Target of goto is too deeply nested";
2133 Perl_croak(aTHX_ too_deep);
2134 if (o->op_type == OP_LEAVE ||
2135 o->op_type == OP_SCOPE ||
2136 o->op_type == OP_LEAVELOOP ||
2137 o->op_type == OP_LEAVETRY)
2139 *ops++ = cUNOPo->op_first;
2141 Perl_croak(aTHX_ too_deep);
2144 if (o->op_flags & OPf_KIDS) {
2145 /* First try all the kids at this level, since that's likeliest. */
2146 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2147 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2148 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2151 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2152 if (kid == PL_lastgotoprobe)
2154 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2156 (ops[-1]->op_type != OP_NEXTSTATE &&
2157 ops[-1]->op_type != OP_DBSTATE)))
2159 if ((o = dofindlabel(kid, label, ops, oplimit)))
2178 register PERL_CONTEXT *cx;
2179 #define GOTO_DEPTH 64
2180 OP *enterops[GOTO_DEPTH];
2182 int do_dump = (PL_op->op_type == OP_DUMP);
2183 static char must_have_label[] = "goto must have label";
2186 if (PL_op->op_flags & OPf_STACKED) {
2190 /* This egregious kludge implements goto &subroutine */
2191 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2193 register PERL_CONTEXT *cx;
2194 CV* cv = (CV*)SvRV(sv);
2200 if (!CvROOT(cv) && !CvXSUB(cv)) {
2205 /* autoloaded stub? */
2206 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2208 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2209 GvNAMELEN(gv), FALSE);
2210 if (autogv && (cv = GvCV(autogv)))
2212 tmpstr = sv_newmortal();
2213 gv_efullname3(tmpstr, gv, Nullch);
2214 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2216 DIE(aTHX_ "Goto undefined subroutine");
2219 /* First do some returnish stuff. */
2220 cxix = dopoptosub(cxstack_ix);
2222 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2223 if (cxix < cxstack_ix)
2226 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2227 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2229 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2230 /* put @_ back onto stack */
2231 AV* av = cx->blk_sub.argarray;
2233 items = AvFILLp(av) + 1;
2235 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2236 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2237 PL_stack_sp += items;
2239 SvREFCNT_dec(GvAV(PL_defgv));
2240 GvAV(PL_defgv) = cx->blk_sub.savearray;
2241 #endif /* USE_THREADS */
2242 /* abandon @_ if it got reified */
2244 (void)sv_2mortal((SV*)av); /* delay until return */
2246 av_extend(av, items-1);
2247 AvFLAGS(av) = AVf_REIFY;
2248 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2251 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2254 av = (AV*)PL_curpad[0];
2256 av = GvAV(PL_defgv);
2258 items = AvFILLp(av) + 1;
2260 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2261 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2262 PL_stack_sp += items;
2264 if (CxTYPE(cx) == CXt_SUB &&
2265 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2266 SvREFCNT_dec(cx->blk_sub.cv);
2267 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2268 LEAVE_SCOPE(oldsave);
2270 /* Now do some callish stuff. */
2273 #ifdef PERL_XSUB_OLDSTYLE
2274 if (CvOLDSTYLE(cv)) {
2275 I32 (*fp3)(int,int,int);
2280 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2281 items = (*fp3)(CvXSUBANY(cv).any_i32,
2282 mark - PL_stack_base + 1,
2284 SP = PL_stack_base + items;
2287 #endif /* PERL_XSUB_OLDSTYLE */
2292 PL_stack_sp--; /* There is no cv arg. */
2293 /* Push a mark for the start of arglist */
2295 (void)(*CvXSUB(cv))(aTHXo_ cv);
2296 /* Pop the current context like a decent sub should */
2297 POPBLOCK(cx, PL_curpm);
2298 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2301 return pop_return();
2304 AV* padlist = CvPADLIST(cv);
2305 SV** svp = AvARRAY(padlist);
2306 if (CxTYPE(cx) == CXt_EVAL) {
2307 PL_in_eval = cx->blk_eval.old_in_eval;
2308 PL_eval_root = cx->blk_eval.old_eval_root;
2309 cx->cx_type = CXt_SUB;
2310 cx->blk_sub.hasargs = 0;
2312 cx->blk_sub.cv = cv;
2313 cx->blk_sub.olddepth = CvDEPTH(cv);
2315 if (CvDEPTH(cv) < 2)
2316 (void)SvREFCNT_inc(cv);
2317 else { /* save temporaries on recursion? */
2318 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2319 sub_crush_depth(cv);
2320 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2321 AV *newpad = newAV();
2322 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2323 I32 ix = AvFILLp((AV*)svp[1]);
2324 I32 names_fill = AvFILLp((AV*)svp[0]);
2325 svp = AvARRAY(svp[0]);
2326 for ( ;ix > 0; ix--) {
2327 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2328 char *name = SvPVX(svp[ix]);
2329 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2332 /* outer lexical or anon code */
2333 av_store(newpad, ix,
2334 SvREFCNT_inc(oldpad[ix]) );
2336 else { /* our own lexical */
2338 av_store(newpad, ix, sv = (SV*)newAV());
2339 else if (*name == '%')
2340 av_store(newpad, ix, sv = (SV*)newHV());
2342 av_store(newpad, ix, sv = NEWSV(0,0));
2346 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2347 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2350 av_store(newpad, ix, sv = NEWSV(0,0));
2354 if (cx->blk_sub.hasargs) {
2357 av_store(newpad, 0, (SV*)av);
2358 AvFLAGS(av) = AVf_REIFY;
2360 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2361 AvFILLp(padlist) = CvDEPTH(cv);
2362 svp = AvARRAY(padlist);
2366 if (!cx->blk_sub.hasargs) {
2367 AV* av = (AV*)PL_curpad[0];
2369 items = AvFILLp(av) + 1;
2371 /* Mark is at the end of the stack. */
2373 Copy(AvARRAY(av), SP + 1, items, SV*);
2378 #endif /* USE_THREADS */
2379 SAVEVPTR(PL_curpad);
2380 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2382 if (cx->blk_sub.hasargs)
2383 #endif /* USE_THREADS */
2385 AV* av = (AV*)PL_curpad[0];
2389 cx->blk_sub.savearray = GvAV(PL_defgv);
2390 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2391 #endif /* USE_THREADS */
2392 cx->blk_sub.oldcurpad = PL_curpad;
2393 cx->blk_sub.argarray = av;
2396 if (items >= AvMAX(av) + 1) {
2398 if (AvARRAY(av) != ary) {
2399 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2400 SvPVX(av) = (char*)ary;
2402 if (items >= AvMAX(av) + 1) {
2403 AvMAX(av) = items - 1;
2404 Renew(ary,items+1,SV*);
2406 SvPVX(av) = (char*)ary;
2409 Copy(mark,AvARRAY(av),items,SV*);
2410 AvFILLp(av) = items - 1;
2411 assert(!AvREAL(av));
2418 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2420 * We do not care about using sv to call CV;
2421 * it's for informational purposes only.
2423 SV *sv = GvSV(PL_DBsub);
2426 if (PERLDB_SUB_NN) {
2427 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2430 gv_efullname3(sv, CvGV(cv), Nullch);
2433 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2434 PUSHMARK( PL_stack_sp );
2435 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2439 RETURNOP(CvSTART(cv));
2443 label = SvPV(sv,n_a);
2444 if (!(do_dump || *label))
2445 DIE(aTHX_ must_have_label);
2448 else if (PL_op->op_flags & OPf_SPECIAL) {
2450 DIE(aTHX_ must_have_label);
2453 label = cPVOP->op_pv;
2455 if (label && *label) {
2457 bool leaving_eval = FALSE;
2458 PERL_CONTEXT *last_eval_cx = 0;
2462 PL_lastgotoprobe = 0;
2464 for (ix = cxstack_ix; ix >= 0; ix--) {
2466 switch (CxTYPE(cx)) {
2468 leaving_eval = TRUE;
2469 if (CxREALEVAL(cx)) {
2470 gotoprobe = (last_eval_cx ?
2471 last_eval_cx->blk_eval.old_eval_root :
2476 /* else fall through */
2478 gotoprobe = cx->blk_oldcop->op_sibling;
2484 gotoprobe = cx->blk_oldcop->op_sibling;
2486 gotoprobe = PL_main_root;
2489 if (CvDEPTH(cx->blk_sub.cv)) {
2490 gotoprobe = CvROOT(cx->blk_sub.cv);
2496 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2499 DIE(aTHX_ "panic: goto");
2500 gotoprobe = PL_main_root;
2504 retop = dofindlabel(gotoprobe, label,
2505 enterops, enterops + GOTO_DEPTH);
2509 PL_lastgotoprobe = gotoprobe;
2512 DIE(aTHX_ "Can't find label %s", label);
2514 /* if we're leaving an eval, check before we pop any frames
2515 that we're not going to punt, otherwise the error
2518 if (leaving_eval && *enterops && enterops[1]) {
2520 for (i = 1; enterops[i]; i++)
2521 if (enterops[i]->op_type == OP_ENTERITER)
2522 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2525 /* pop unwanted frames */
2527 if (ix < cxstack_ix) {
2534 oldsave = PL_scopestack[PL_scopestack_ix];
2535 LEAVE_SCOPE(oldsave);
2538 /* push wanted frames */
2540 if (*enterops && enterops[1]) {
2542 for (ix = 1; enterops[ix]; ix++) {
2543 PL_op = enterops[ix];
2544 /* Eventually we may want to stack the needed arguments
2545 * for each op. For now, we punt on the hard ones. */
2546 if (PL_op->op_type == OP_ENTERITER)
2547 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2548 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2556 if (!retop) retop = PL_main_start;
2558 PL_restartop = retop;
2559 PL_do_undump = TRUE;
2563 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2564 PL_do_undump = FALSE;
2580 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2584 PL_exit_flags |= PERL_EXIT_EXPECTED;
2586 PUSHs(&PL_sv_undef);
2594 NV value = SvNVx(GvSV(cCOP->cop_gv));
2595 register I32 match = I_32(value);
2598 if (((NV)match) > value)
2599 --match; /* was fractional--truncate other way */
2601 match -= cCOP->uop.scop.scop_offset;
2604 else if (match > cCOP->uop.scop.scop_max)
2605 match = cCOP->uop.scop.scop_max;
2606 PL_op = cCOP->uop.scop.scop_next[match];
2616 PL_op = PL_op->op_next; /* can't assume anything */
2619 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2620 match -= cCOP->uop.scop.scop_offset;
2623 else if (match > cCOP->uop.scop.scop_max)
2624 match = cCOP->uop.scop.scop_max;
2625 PL_op = cCOP->uop.scop.scop_next[match];
2634 S_save_lines(pTHX_ AV *array, SV *sv)
2636 register char *s = SvPVX(sv);
2637 register char *send = SvPVX(sv) + SvCUR(sv);
2639 register I32 line = 1;
2641 while (s && s < send) {
2642 SV *tmpstr = NEWSV(85,0);
2644 sv_upgrade(tmpstr, SVt_PVMG);
2645 t = strchr(s, '\n');
2651 sv_setpvn(tmpstr, s, t - s);
2652 av_store(array, line++, tmpstr);
2657 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2659 S_docatch_body(pTHX_ va_list args)
2661 return docatch_body();
2666 S_docatch_body(pTHX)
2673 S_docatch(pTHX_ OP *o)
2677 volatile PERL_SI *cursi = PL_curstackinfo;
2681 assert(CATCH_GET == TRUE);
2684 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2686 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2692 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2698 if (PL_restartop && cursi == PL_curstackinfo) {
2699 PL_op = PL_restartop;
2716 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2717 /* sv Text to convert to OP tree. */
2718 /* startop op_free() this to undo. */
2719 /* code Short string id of the caller. */
2721 dSP; /* Make POPBLOCK work. */
2724 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2728 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2729 char *tmpbuf = tbuf;
2735 /* switch to eval mode */
2737 if (PL_curcop == &PL_compiling) {
2738 SAVECOPSTASH_FREE(&PL_compiling);
2739 CopSTASH_set(&PL_compiling, PL_curstash);
2741 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2742 SV *sv = sv_newmortal();
2743 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2744 code, (unsigned long)++PL_evalseq,
2745 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2749 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2750 SAVECOPFILE_FREE(&PL_compiling);
2751 CopFILE_set(&PL_compiling, tmpbuf+2);
2752 SAVECOPLINE(&PL_compiling);
2753 CopLINE_set(&PL_compiling, 1);
2754 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2755 deleting the eval's FILEGV from the stash before gv_check() runs
2756 (i.e. before run-time proper). To work around the coredump that
2757 ensues, we always turn GvMULTI_on for any globals that were
2758 introduced within evals. See force_ident(). GSAR 96-10-12 */
2759 safestr = savepv(tmpbuf);
2760 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2762 #ifdef OP_IN_REGISTER
2767 PL_hints &= HINT_UTF8;
2770 PL_op->op_type = OP_ENTEREVAL;
2771 PL_op->op_flags = 0; /* Avoid uninit warning. */
2772 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2773 PUSHEVAL(cx, 0, Nullgv);
2774 rop = doeval(G_SCALAR, startop);
2775 POPBLOCK(cx,PL_curpm);
2778 (*startop)->op_type = OP_NULL;
2779 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2781 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2783 if (PL_curcop == &PL_compiling)
2784 PL_compiling.op_private = PL_hints;
2785 #ifdef OP_IN_REGISTER
2791 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2793 S_doeval(pTHX_ int gimme, OP** startop)
2801 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2802 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2807 /* set up a scratch pad */
2810 SAVEVPTR(PL_curpad);
2811 SAVESPTR(PL_comppad);
2812 SAVESPTR(PL_comppad_name);
2813 SAVEI32(PL_comppad_name_fill);
2814 SAVEI32(PL_min_intro_pending);
2815 SAVEI32(PL_max_intro_pending);
2818 for (i = cxstack_ix - 1; i >= 0; i--) {
2819 PERL_CONTEXT *cx = &cxstack[i];
2820 if (CxTYPE(cx) == CXt_EVAL)
2822 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2823 caller = cx->blk_sub.cv;
2828 SAVESPTR(PL_compcv);
2829 PL_compcv = (CV*)NEWSV(1104,0);
2830 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2831 CvEVAL_on(PL_compcv);
2833 CvOWNER(PL_compcv) = 0;
2834 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2835 MUTEX_INIT(CvMUTEXP(PL_compcv));
2836 #endif /* USE_THREADS */
2838 PL_comppad = newAV();
2839 av_push(PL_comppad, Nullsv);
2840 PL_curpad = AvARRAY(PL_comppad);
2841 PL_comppad_name = newAV();
2842 PL_comppad_name_fill = 0;
2843 PL_min_intro_pending = 0;
2846 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2847 PL_curpad[0] = (SV*)newAV();
2848 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2849 #endif /* USE_THREADS */
2851 comppadlist = newAV();
2852 AvREAL_off(comppadlist);
2853 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2854 av_store(comppadlist, 1, (SV*)PL_comppad);
2855 CvPADLIST(PL_compcv) = comppadlist;
2858 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2860 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2863 SAVEFREESV(PL_compcv);
2865 /* make sure we compile in the right package */
2867 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2868 SAVESPTR(PL_curstash);
2869 PL_curstash = CopSTASH(PL_curcop);
2871 SAVESPTR(PL_beginav);
2872 PL_beginav = newAV();
2873 SAVEFREESV(PL_beginav);
2874 SAVEI32(PL_error_count);
2876 /* try to compile it */
2878 PL_eval_root = Nullop;
2880 PL_curcop = &PL_compiling;
2881 PL_curcop->cop_arybase = 0;
2882 SvREFCNT_dec(PL_rs);
2883 PL_rs = newSVpvn("\n", 1);
2884 if (saveop && saveop->op_flags & OPf_SPECIAL)
2885 PL_in_eval |= EVAL_KEEPERR;
2888 if (yyparse() || PL_error_count || !PL_eval_root) {
2892 I32 optype = 0; /* Might be reset by POPEVAL. */
2897 op_free(PL_eval_root);
2898 PL_eval_root = Nullop;
2900 SP = PL_stack_base + POPMARK; /* pop original mark */
2902 POPBLOCK(cx,PL_curpm);
2908 if (optype == OP_REQUIRE) {
2909 char* msg = SvPVx(ERRSV, n_a);
2910 DIE(aTHX_ "%sCompilation failed in require",
2911 *msg ? msg : "Unknown error\n");
2914 char* msg = SvPVx(ERRSV, n_a);
2916 POPBLOCK(cx,PL_curpm);
2918 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2919 (*msg ? msg : "Unknown error\n"));
2921 SvREFCNT_dec(PL_rs);
2922 PL_rs = SvREFCNT_inc(PL_nrs);
2924 MUTEX_LOCK(&PL_eval_mutex);
2926 COND_SIGNAL(&PL_eval_cond);
2927 MUTEX_UNLOCK(&PL_eval_mutex);
2928 #endif /* USE_THREADS */
2931 SvREFCNT_dec(PL_rs);
2932 PL_rs = SvREFCNT_inc(PL_nrs);
2933 CopLINE_set(&PL_compiling, 0);
2935 *startop = PL_eval_root;
2936 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2937 CvOUTSIDE(PL_compcv) = Nullcv;
2939 SAVEFREEOP(PL_eval_root);
2941 scalarvoid(PL_eval_root);
2942 else if (gimme & G_ARRAY)
2945 scalar(PL_eval_root);
2947 DEBUG_x(dump_eval());
2949 /* Register with debugger: */
2950 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2951 CV *cv = get_cv("DB::postponed", FALSE);
2955 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2957 call_sv((SV*)cv, G_DISCARD);
2961 /* compiled okay, so do it */
2963 CvDEPTH(PL_compcv) = 1;
2964 SP = PL_stack_base + POPMARK; /* pop original mark */
2965 PL_op = saveop; /* The caller may need it. */
2966 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2968 MUTEX_LOCK(&PL_eval_mutex);
2970 COND_SIGNAL(&PL_eval_cond);
2971 MUTEX_UNLOCK(&PL_eval_mutex);
2972 #endif /* USE_THREADS */
2974 RETURNOP(PL_eval_start);
2978 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2980 STRLEN namelen = strlen(name);
2983 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2984 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2985 char *pmc = SvPV_nolen(pmcsv);
2988 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2989 fp = PerlIO_open(name, mode);
2992 if (PerlLIO_stat(name, &pmstat) < 0 ||
2993 pmstat.st_mtime < pmcstat.st_mtime)
2995 fp = PerlIO_open(pmc, mode);
2998 fp = PerlIO_open(name, mode);
3001 SvREFCNT_dec(pmcsv);
3004 fp = PerlIO_open(name, mode);
3012 register PERL_CONTEXT *cx;
3017 SV *namesv = Nullsv;
3019 I32 gimme = G_SCALAR;
3020 PerlIO *tryrsfp = 0;
3022 int filter_has_file = 0;
3023 GV *filter_child_proc = 0;
3024 SV *filter_state = 0;
3029 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3030 UV rev = 0, ver = 0, sver = 0;
3032 U8 *s = (U8*)SvPVX(sv);
3033 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3035 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3038 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3041 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3044 if (PERL_REVISION < rev
3045 || (PERL_REVISION == rev
3046 && (PERL_VERSION < ver
3047 || (PERL_VERSION == ver
3048 && PERL_SUBVERSION < sver))))
3050 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3051 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3052 PERL_VERSION, PERL_SUBVERSION);
3056 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3057 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3058 + ((NV)PERL_SUBVERSION/(NV)1000000)
3059 + 0.00000099 < SvNV(sv))
3063 NV nver = (nrev - rev) * 1000;
3064 UV ver = (UV)(nver + 0.0009);
3065 NV nsver = (nver - ver) * 1000;
3066 UV sver = (UV)(nsver + 0.0009);
3068 /* help out with the "use 5.6" confusion */
3069 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3070 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3071 "this is only v%d.%d.%d, stopped"
3072 " (did you mean v%"UVuf".%"UVuf".0?)",
3073 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3074 PERL_SUBVERSION, rev, ver/100);
3077 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3078 "this is only v%d.%d.%d, stopped",
3079 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3086 name = SvPV(sv, len);
3087 if (!(name && len > 0 && *name))
3088 DIE(aTHX_ "Null filename used");
3089 TAINT_PROPER("require");
3090 if (PL_op->op_type == OP_REQUIRE &&
3091 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3092 *svp != &PL_sv_undef)
3095 /* prepare to compile file */
3097 #ifdef MACOS_TRADITIONAL
3098 if (PERL_FILE_IS_ABSOLUTE(name)
3099 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3102 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3103 /* We consider paths of the form :a:b ambiguous and interpret them first
3104 as global then as local
3106 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3112 if (PERL_FILE_IS_ABSOLUTE(name)
3113 || (*name == '.' && (name[1] == '/' ||
3114 (name[1] == '.' && name[2] == '/'))))
3117 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3121 AV *ar = GvAVn(PL_incgv);
3125 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3128 namesv = NEWSV(806, 0);
3129 for (i = 0; i <= AvFILL(ar); i++) {
3130 SV *dirsv = *av_fetch(ar, i, TRUE);
3136 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3137 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3140 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3141 PTR2UV(SvANY(loader)), name);
3142 tryname = SvPVX(namesv);
3153 if (sv_isobject(loader))
3154 count = call_method("INC", G_ARRAY);
3156 count = call_sv(loader, G_ARRAY);
3166 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3170 if (SvTYPE(arg) == SVt_PVGV) {
3171 IO *io = GvIO((GV *)arg);
3176 tryrsfp = IoIFP(io);
3177 if (IoTYPE(io) == IoTYPE_PIPE) {
3178 /* reading from a child process doesn't
3179 nest -- when returning from reading
3180 the inner module, the outer one is
3181 unreadable (closed?) I've tried to
3182 save the gv to manage the lifespan of
3183 the pipe, but this didn't help. XXX */
3184 filter_child_proc = (GV *)arg;
3185 (void)SvREFCNT_inc(filter_child_proc);
3188 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3189 PerlIO_close(IoOFP(io));
3201 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3203 (void)SvREFCNT_inc(filter_sub);
3206 filter_state = SP[i];
3207 (void)SvREFCNT_inc(filter_state);
3211 tryrsfp = PerlIO_open("/dev/null",
3225 filter_has_file = 0;
3226 if (filter_child_proc) {
3227 SvREFCNT_dec(filter_child_proc);
3228 filter_child_proc = 0;
3231 SvREFCNT_dec(filter_state);
3235 SvREFCNT_dec(filter_sub);
3240 char *dir = SvPVx(dirsv, n_a);
3241 #ifdef MACOS_TRADITIONAL
3243 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3247 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3249 sv_setpv(namesv, unixdir);
3250 sv_catpv(namesv, unixname);
3252 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3255 TAINT_PROPER("require");
3256 tryname = SvPVX(namesv);
3257 #ifdef MACOS_TRADITIONAL
3259 /* Convert slashes in the name part, but not the directory part, to colons */
3261 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3265 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3267 if (tryname[0] == '.' && tryname[1] == '/')
3275 SAVECOPFILE_FREE(&PL_compiling);
3276 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3277 SvREFCNT_dec(namesv);
3279 if (PL_op->op_type == OP_REQUIRE) {
3280 char *msgstr = name;
3281 if (namesv) { /* did we lookup @INC? */
3282 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3283 SV *dirmsgsv = NEWSV(0, 0);
3284 AV *ar = GvAVn(PL_incgv);
3286 sv_catpvn(msg, " in @INC", 8);
3287 if (instr(SvPVX(msg), ".h "))
3288 sv_catpv(msg, " (change .h to .ph maybe?)");
3289 if (instr(SvPVX(msg), ".ph "))
3290 sv_catpv(msg, " (did you run h2ph?)");
3291 sv_catpv(msg, " (@INC contains:");
3292 for (i = 0; i <= AvFILL(ar); i++) {
3293 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3294 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3295 sv_catsv(msg, dirmsgsv);
3297 sv_catpvn(msg, ")", 1);
3298 SvREFCNT_dec(dirmsgsv);
3299 msgstr = SvPV_nolen(msg);
3301 DIE(aTHX_ "Can't locate %s", msgstr);
3307 SETERRNO(0, SS$_NORMAL);
3309 /* Assume success here to prevent recursive requirement. */
3310 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3311 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3315 lex_start(sv_2mortal(newSVpvn("",0)));
3316 SAVEGENERICSV(PL_rsfp_filters);
3317 PL_rsfp_filters = Nullav;
3322 SAVESPTR(PL_compiling.cop_warnings);
3323 if (PL_dowarn & G_WARN_ALL_ON)
3324 PL_compiling.cop_warnings = pWARN_ALL ;
3325 else if (PL_dowarn & G_WARN_ALL_OFF)
3326 PL_compiling.cop_warnings = pWARN_NONE ;
3328 PL_compiling.cop_warnings = pWARN_STD ;
3329 SAVESPTR(PL_compiling.cop_io);
3330 PL_compiling.cop_io = Nullsv;
3332 if (filter_sub || filter_child_proc) {
3333 SV *datasv = filter_add(run_user_filter, Nullsv);
3334 IoLINES(datasv) = filter_has_file;
3335 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3336 IoTOP_GV(datasv) = (GV *)filter_state;
3337 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3340 /* switch to eval mode */
3341 push_return(PL_op->op_next);
3342 PUSHBLOCK(cx, CXt_EVAL, SP);
3343 PUSHEVAL(cx, name, Nullgv);
3345 SAVECOPLINE(&PL_compiling);
3346 CopLINE_set(&PL_compiling, 0);
3350 MUTEX_LOCK(&PL_eval_mutex);
3351 if (PL_eval_owner && PL_eval_owner != thr)
3352 while (PL_eval_owner)
3353 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3354 PL_eval_owner = thr;
3355 MUTEX_UNLOCK(&PL_eval_mutex);
3356 #endif /* USE_THREADS */
3357 return DOCATCH(doeval(G_SCALAR, NULL));
3362 return pp_require();
3368 register PERL_CONTEXT *cx;
3370 I32 gimme = GIMME_V, was = PL_sub_generation;
3371 char tbuf[TYPE_DIGITS(long) + 12];
3372 char *tmpbuf = tbuf;
3377 if (!SvPV(sv,len) || !len)
3379 TAINT_PROPER("eval");
3385 /* switch to eval mode */
3387 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3388 SV *sv = sv_newmortal();
3389 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3390 (unsigned long)++PL_evalseq,
3391 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3395 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3396 SAVECOPFILE_FREE(&PL_compiling);
3397 CopFILE_set(&PL_compiling, tmpbuf+2);
3398 SAVECOPLINE(&PL_compiling);
3399 CopLINE_set(&PL_compiling, 1);
3400 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3401 deleting the eval's FILEGV from the stash before gv_check() runs
3402 (i.e. before run-time proper). To work around the coredump that
3403 ensues, we always turn GvMULTI_on for any globals that were
3404 introduced within evals. See force_ident(). GSAR 96-10-12 */
3405 safestr = savepv(tmpbuf);
3406 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3408 PL_hints = PL_op->op_targ;
3409 SAVESPTR(PL_compiling.cop_warnings);
3410 if (specialWARN(PL_curcop->cop_warnings))
3411 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3413 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3414 SAVEFREESV(PL_compiling.cop_warnings);
3416 SAVESPTR(PL_compiling.cop_io);
3417 if (specialCopIO(PL_curcop->cop_io))
3418 PL_compiling.cop_io = PL_curcop->cop_io;
3420 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3421 SAVEFREESV(PL_compiling.cop_io);
3424 push_return(PL_op->op_next);
3425 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3426 PUSHEVAL(cx, 0, Nullgv);
3428 /* prepare to compile string */
3430 if (PERLDB_LINE && PL_curstash != PL_debstash)
3431 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3434 MUTEX_LOCK(&PL_eval_mutex);
3435 if (PL_eval_owner && PL_eval_owner != thr)
3436 while (PL_eval_owner)
3437 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3438 PL_eval_owner = thr;
3439 MUTEX_UNLOCK(&PL_eval_mutex);
3440 #endif /* USE_THREADS */
3441 ret = doeval(gimme, NULL);
3442 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3443 && ret != PL_op->op_next) { /* Successive compilation. */
3444 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3446 return DOCATCH(ret);
3456 register PERL_CONTEXT *cx;
3458 U8 save_flags = PL_op -> op_flags;
3463 retop = pop_return();
3466 if (gimme == G_VOID)
3468 else if (gimme == G_SCALAR) {
3471 if (SvFLAGS(TOPs) & SVs_TEMP)
3474 *MARK = sv_mortalcopy(TOPs);
3478 *MARK = &PL_sv_undef;
3483 /* in case LEAVE wipes old return values */
3484 for (mark = newsp + 1; mark <= SP; mark++) {
3485 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3486 *mark = sv_mortalcopy(*mark);
3487 TAINT_NOT; /* Each item is independent */
3491 PL_curpm = newpm; /* Don't pop $1 et al till now */
3494 assert(CvDEPTH(PL_compcv) == 1);
3496 CvDEPTH(PL_compcv) = 0;
3499 if (optype == OP_REQUIRE &&
3500 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3502 /* Unassume the success we assumed earlier. */
3503 SV *nsv = cx->blk_eval.old_namesv;
3504 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3505 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3506 /* die_where() did LEAVE, or we won't be here */
3510 if (!(save_flags & OPf_SPECIAL))
3520 register PERL_CONTEXT *cx;
3521 I32 gimme = GIMME_V;
3526 push_return(cLOGOP->op_other->op_next);
3527 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3530 PL_in_eval = EVAL_INEVAL;
3533 return DOCATCH(PL_op->op_next);
3543 register PERL_CONTEXT *cx;
3551 if (gimme == G_VOID)
3553 else if (gimme == G_SCALAR) {
3556 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3559 *MARK = sv_mortalcopy(TOPs);
3563 *MARK = &PL_sv_undef;
3568 /* in case LEAVE wipes old return values */
3569 for (mark = newsp + 1; mark <= SP; mark++) {
3570 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3571 *mark = sv_mortalcopy(*mark);
3572 TAINT_NOT; /* Each item is independent */
3576 PL_curpm = newpm; /* Don't pop $1 et al till now */
3584 S_doparseform(pTHX_ SV *sv)
3587 register char *s = SvPV_force(sv, len);
3588 register char *send = s + len;
3589 register char *base;
3590 register I32 skipspaces = 0;
3593 bool postspace = FALSE;
3601 Perl_croak(aTHX_ "Null picture in formline");
3603 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3608 *fpc++ = FF_LINEMARK;
3609 noblank = repeat = FALSE;
3627 case ' ': case '\t':
3638 *fpc++ = FF_LITERAL;
3646 *fpc++ = skipspaces;
3650 *fpc++ = FF_NEWLINE;
3654 arg = fpc - linepc + 1;
3661 *fpc++ = FF_LINEMARK;
3662 noblank = repeat = FALSE;
3671 ischop = s[-1] == '^';
3677 arg = (s - base) - 1;
3679 *fpc++ = FF_LITERAL;
3688 *fpc++ = FF_LINEGLOB;
3690 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3691 arg = ischop ? 512 : 0;
3701 arg |= 256 + (s - f);
3703 *fpc++ = s - base; /* fieldsize for FETCH */
3704 *fpc++ = FF_DECIMAL;
3707 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3708 arg = ischop ? 512 : 0;
3710 s++; /* skip the '0' first */
3719 arg |= 256 + (s - f);
3721 *fpc++ = s - base; /* fieldsize for FETCH */
3722 *fpc++ = FF_0DECIMAL;
3727 bool ismore = FALSE;
3730 while (*++s == '>') ;
3731 prespace = FF_SPACE;
3733 else if (*s == '|') {
3734 while (*++s == '|') ;
3735 prespace = FF_HALFSPACE;
3740 while (*++s == '<') ;
3743 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3747 *fpc++ = s - base; /* fieldsize for FETCH */
3749 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3767 { /* need to jump to the next word */
3769 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3770 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3771 s = SvPVX(sv) + SvCUR(sv) + z;
3773 Copy(fops, s, arg, U16);
3775 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3780 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3782 * The original code was written in conjunction with BSD Computer Software
3783 * Research Group at University of California, Berkeley.
3785 * See also: "Optimistic Merge Sort" (SODA '92)
3787 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3789 * The code can be distributed under the same terms as Perl itself.
3794 #include <sys/types.h>
3799 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3800 #define Safefree(VAR) free(VAR)
3801 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3802 #endif /* TESTHARNESS */
3804 typedef char * aptr; /* pointer for arithmetic on sizes */
3805 typedef SV * gptr; /* pointers in our lists */
3807 /* Binary merge internal sort, with a few special mods
3808 ** for the special perl environment it now finds itself in.
3810 ** Things that were once options have been hotwired
3811 ** to values suitable for this use. In particular, we'll always
3812 ** initialize looking for natural runs, we'll always produce stable
3813 ** output, and we'll always do Peter McIlroy's binary merge.
3816 /* Pointer types for arithmetic and storage and convenience casts */
3818 #define APTR(P) ((aptr)(P))
3819 #define GPTP(P) ((gptr *)(P))
3820 #define GPPP(P) ((gptr **)(P))
3823 /* byte offset from pointer P to (larger) pointer Q */
3824 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3826 #define PSIZE sizeof(gptr)
3828 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3831 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3832 #define PNBYTE(N) ((N) << (PSHIFT))
3833 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3835 /* Leave optimization to compiler */
3836 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3837 #define PNBYTE(N) ((N) * (PSIZE))
3838 #define PINDEX(P, N) (GPTP(P) + (N))
3841 /* Pointer into other corresponding to pointer into this */
3842 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3844 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3847 /* Runs are identified by a pointer in the auxilliary list.
3848 ** The pointer is at the start of the list,
3849 ** and it points to the start of the next list.
3850 ** NEXT is used as an lvalue, too.
3853 #define NEXT(P) (*GPPP(P))
3856 /* PTHRESH is the minimum number of pairs with the same sense to justify
3857 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3858 ** not just elements, so PTHRESH == 8 means a run of 16.
3863 /* RTHRESH is the number of elements in a run that must compare low
3864 ** to the low element from the opposing run before we justify
3865 ** doing a binary rampup instead of single stepping.
3866 ** In random input, N in a row low should only happen with
3867 ** probability 2^(1-N), so we can risk that we are dealing
3868 ** with orderly input without paying much when we aren't.
3875 ** Overview of algorithm and variables.
3876 ** The array of elements at list1 will be organized into runs of length 2,
3877 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3878 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3880 ** Unless otherwise specified, pair pointers address the first of two elements.
3882 ** b and b+1 are a pair that compare with sense ``sense''.
3883 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3885 ** p2 parallels b in the list2 array, where runs are defined by
3888 ** t represents the ``top'' of the adjacent pairs that might extend
3889 ** the run beginning at b. Usually, t addresses a pair
3890 ** that compares with opposite sense from (b,b+1).
3891 ** However, it may also address a singleton element at the end of list1,
3892 ** or it may be equal to ``last'', the first element beyond list1.
3894 ** r addresses the Nth pair following b. If this would be beyond t,
3895 ** we back it off to t. Only when r is less than t do we consider the
3896 ** run long enough to consider checking.
3898 ** q addresses a pair such that the pairs at b through q already form a run.
3899 ** Often, q will equal b, indicating we only are sure of the pair itself.
3900 ** However, a search on the previous cycle may have revealed a longer run,
3901 ** so q may be greater than b.
3903 ** p is used to work back from a candidate r, trying to reach q,
3904 ** which would mean b through r would be a run. If we discover such a run,
3905 ** we start q at r and try to push it further towards t.
3906 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3907 ** In any event, after the check (if any), we have two main cases.
3909 ** 1) Short run. b <= q < p <= r <= t.
3910 ** b through q is a run (perhaps trivial)
3911 ** q through p are uninteresting pairs
3912 ** p through r is a run
3914 ** 2) Long run. b < r <= q < t.
3915 ** b through q is a run (of length >= 2 * PTHRESH)
3917 ** Note that degenerate cases are not only possible, but likely.
3918 ** For example, if the pair following b compares with opposite sense,
3919 ** then b == q < p == r == t.
3924 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3927 register gptr *b, *p, *q, *t, *p2;
3928 register gptr c, *last, *r;
3932 last = PINDEX(b, nmemb);
3933 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3934 for (p2 = list2; b < last; ) {
3935 /* We just started, or just reversed sense.
3936 ** Set t at end of pairs with the prevailing sense.
3938 for (p = b+2, t = p; ++p < last; t = ++p) {
3939 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3942 /* Having laid out the playing field, look for long runs */
3944 p = r = b + (2 * PTHRESH);
3945 if (r >= t) p = r = t; /* too short to care about */
3947 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3950 /* b through r is a (long) run.
3951 ** Extend it as far as possible.
3954 while (((p += 2) < t) &&
3955 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3956 r = p = q + 2; /* no simple pairs, no after-run */
3959 if (q > b) { /* run of greater than 2 at b */
3962 /* pick up singleton, if possible */
3964 ((t + 1) == last) &&
3965 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3966 savep = r = p = q = last;
3967 p2 = NEXT(p2) = p2 + (p - b);
3968 if (sense) while (b < --p) {
3975 while (q < p) { /* simple pairs */
3976 p2 = NEXT(p2) = p2 + 2;
3983 if (((b = p) == t) && ((t+1) == last)) {
3995 /* Overview of bmerge variables:
3997 ** list1 and list2 address the main and auxiliary arrays.
3998 ** They swap identities after each merge pass.
3999 ** Base points to the original list1, so we can tell if
4000 ** the pointers ended up where they belonged (or must be copied).
4002 ** When we are merging two lists, f1 and f2 are the next elements
4003 ** on the respective lists. l1 and l2 mark the end of the lists.
4004 ** tp2 is the current location in the merged list.
4006 ** p1 records where f1 started.
4007 ** After the merge, a new descriptor is built there.
4009 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4010 ** It is used to identify and delimit the runs.
4012 ** In the heat of determining where q, the greater of the f1/f2 elements,
4013 ** belongs in the other list, b, t and p, represent bottom, top and probe
4014 ** locations, respectively, in the other list.
4015 ** They make convenient temporary pointers in other places.
4019 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4023 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4024 gptr *aux, *list2, *p2, *last;
4028 if (nmemb <= 1) return; /* sorted trivially */
4029 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4031 dynprep(aTHX_ list1, list2, nmemb, cmp);
4032 last = PINDEX(list2, nmemb);
4033 while (NEXT(list2) != last) {
4034 /* More than one run remains. Do some merging to reduce runs. */
4036 for (tp2 = p2 = list2; p2 != last;) {
4037 /* The new first run begins where the old second list ended.
4038 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4042 f2 = l1 = POTHER(t, list2, list1);
4043 if (t != last) t = NEXT(t);
4044 l2 = POTHER(t, list2, list1);
4046 while (f1 < l1 && f2 < l2) {
4047 /* If head 1 is larger than head 2, find ALL the elements
4048 ** in list 2 strictly less than head1, write them all,
4049 ** then head 1. Then compare the new heads, and repeat,
4050 ** until one or both lists are exhausted.
4052 ** In all comparisons (after establishing
4053 ** which head to merge) the item to merge
4054 ** (at pointer q) is the first operand of
4055 ** the comparison. When we want to know
4056 ** if ``q is strictly less than the other'',
4058 ** cmp(q, other) < 0
4059 ** because stability demands that we treat equality
4060 ** as high when q comes from l2, and as low when
4061 ** q was from l1. So we ask the question by doing
4062 ** cmp(q, other) <= sense
4063 ** and make sense == 0 when equality should look low,
4064 ** and -1 when equality should look high.
4068 if (cmp(aTHX_ *f1, *f2) <= 0) {
4069 q = f2; b = f1; t = l1;
4072 q = f1; b = f2; t = l2;
4079 ** Leave t at something strictly
4080 ** greater than q (or at the end of the list),
4081 ** and b at something strictly less than q.
4083 for (i = 1, run = 0 ;;) {
4084 if ((p = PINDEX(b, i)) >= t) {
4086 if (((p = PINDEX(t, -1)) > b) &&
4087 (cmp(aTHX_ *q, *p) <= sense))
4091 } else if (cmp(aTHX_ *q, *p) <= sense) {
4095 if (++run >= RTHRESH) i += i;
4099 /* q is known to follow b and must be inserted before t.
4100 ** Increment b, so the range of possibilities is [b,t).
4101 ** Round binary split down, to favor early appearance.
4102 ** Adjust b and t until q belongs just before t.
4107 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4108 if (cmp(aTHX_ *q, *p) <= sense) {
4114 /* Copy all the strictly low elements */
4117 FROMTOUPTO(f2, tp2, t);
4120 FROMTOUPTO(f1, tp2, t);
4126 /* Run out remaining list */
4128 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4129 } else FROMTOUPTO(f1, tp2, l1);
4130 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4135 last = PINDEX(list2, nmemb);
4137 if (base == list2) {
4138 last = PINDEX(list1, nmemb);
4139 FROMTOUPTO(list1, list2, last);
4154 sortcv(pTHXo_ SV *a, SV *b)
4156 I32 oldsaveix = PL_savestack_ix;
4157 I32 oldscopeix = PL_scopestack_ix;
4159 GvSV(PL_firstgv) = a;
4160 GvSV(PL_secondgv) = b;
4161 PL_stack_sp = PL_stack_base;
4164 if (PL_stack_sp != PL_stack_base + 1)
4165 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4166 if (!SvNIOKp(*PL_stack_sp))
4167 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4168 result = SvIV(*PL_stack_sp);
4169 while (PL_scopestack_ix > oldscopeix) {
4172 leave_scope(oldsaveix);
4177 sortcv_stacked(pTHXo_ SV *a, SV *b)
4179 I32 oldsaveix = PL_savestack_ix;
4180 I32 oldscopeix = PL_scopestack_ix;
4185 av = (AV*)PL_curpad[0];
4187 av = GvAV(PL_defgv);
4190 if (AvMAX(av) < 1) {
4191 SV** ary = AvALLOC(av);
4192 if (AvARRAY(av) != ary) {
4193 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4194 SvPVX(av) = (char*)ary;
4196 if (AvMAX(av) < 1) {
4199 SvPVX(av) = (char*)ary;
4206 PL_stack_sp = PL_stack_base;
4209 if (PL_stack_sp != PL_stack_base + 1)
4210 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4211 if (!SvNIOKp(*PL_stack_sp))
4212 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4213 result = SvIV(*PL_stack_sp);
4214 while (PL_scopestack_ix > oldscopeix) {
4217 leave_scope(oldsaveix);
4222 sortcv_xsub(pTHXo_ SV *a, SV *b)
4225 I32 oldsaveix = PL_savestack_ix;
4226 I32 oldscopeix = PL_scopestack_ix;
4228 CV *cv=(CV*)PL_sortcop;
4236 (void)(*CvXSUB(cv))(aTHXo_ cv);
4237 if (PL_stack_sp != PL_stack_base + 1)
4238 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4239 if (!SvNIOKp(*PL_stack_sp))
4240 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4241 result = SvIV(*PL_stack_sp);
4242 while (PL_scopestack_ix > oldscopeix) {
4245 leave_scope(oldsaveix);
4251 sv_ncmp(pTHXo_ SV *a, SV *b)
4255 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4259 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4263 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4265 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4267 if (PL_amagic_generation) { \
4268 if (SvAMAGIC(left)||SvAMAGIC(right))\
4269 *svp = amagic_call(left, \
4277 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4280 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4285 I32 i = SvIVX(tmpsv);
4295 return sv_ncmp(aTHXo_ a, b);
4299 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4302 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4307 I32 i = SvIVX(tmpsv);
4317 return sv_i_ncmp(aTHXo_ a, b);
4321 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4324 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4329 I32 i = SvIVX(tmpsv);
4339 return sv_cmp(str1, str2);
4343 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4346 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4351 I32 i = SvIVX(tmpsv);
4361 return sv_cmp_locale(str1, str2);
4365 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4367 SV *datasv = FILTER_DATA(idx);
4368 int filter_has_file = IoLINES(datasv);
4369 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4370 SV *filter_state = (SV *)IoTOP_GV(datasv);
4371 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4374 /* I was having segfault trouble under Linux 2.2.5 after a
4375 parse error occured. (Had to hack around it with a test
4376 for PL_error_count == 0.) Solaris doesn't segfault --
4377 not sure where the trouble is yet. XXX */
4379 if (filter_has_file) {
4380 len = FILTER_READ(idx+1, buf_sv, maxlen);
4383 if (filter_sub && len >= 0) {
4394 PUSHs(sv_2mortal(newSViv(maxlen)));
4396 PUSHs(filter_state);
4399 count = call_sv(filter_sub, G_SCALAR);
4415 IoLINES(datasv) = 0;
4416 if (filter_child_proc) {
4417 SvREFCNT_dec(filter_child_proc);
4418 IoFMT_GV(datasv) = Nullgv;
4421 SvREFCNT_dec(filter_state);
4422 IoTOP_GV(datasv) = Nullgv;
4425 SvREFCNT_dec(filter_sub);
4426 IoBOTTOM_GV(datasv) = Nullgv;
4428 filter_del(run_user_filter);
4437 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4439 return sv_cmp_locale(str1, str2);
4443 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4445 return sv_cmp(str1, str2);
4448 #endif /* PERL_OBJECT */