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 = bytes_to_utf8(t, &len);
124 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
125 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
127 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
128 inside tie/overload accessors. */
132 #ifndef INCOMPLETE_TAINTS
135 pm->op_pmdynflags |= PMdf_TAINTED;
137 pm->op_pmdynflags &= ~PMdf_TAINTED;
141 if (!pm->op_pmregexp->prelen && PL_curpm)
143 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
144 pm->op_pmflags |= PMf_WHITE;
146 /* XXX runtime compiled output needs to move to the pad */
147 if (pm->op_pmflags & PMf_KEEP) {
148 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
149 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
150 /* XXX can't change the optree at runtime either */
151 cLOGOP->op_first->op_next = PL_op->op_next;
160 register PMOP *pm = (PMOP*) cLOGOP->op_other;
161 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
162 register SV *dstr = cx->sb_dstr;
163 register char *s = cx->sb_s;
164 register char *m = cx->sb_m;
165 char *orig = cx->sb_orig;
166 register REGEXP *rx = cx->sb_rx;
168 rxres_restore(&cx->sb_rxres, rx);
170 if (cx->sb_iters++) {
171 if (cx->sb_iters > cx->sb_maxiters)
172 DIE(aTHX_ "Substitution loop");
174 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
175 cx->sb_rxtainted |= 2;
176 sv_catsv(dstr, POPs);
179 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
180 s == m, cx->sb_targ, NULL,
181 ((cx->sb_rflags & REXEC_COPY_STR)
182 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
183 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
185 SV *targ = cx->sb_targ;
187 sv_catpvn(dstr, s, cx->sb_strend - s);
188 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
190 (void)SvOOK_off(targ);
191 Safefree(SvPVX(targ));
192 SvPVX(targ) = SvPVX(dstr);
193 SvCUR_set(targ, SvCUR(dstr));
194 SvLEN_set(targ, SvLEN(dstr));
200 TAINT_IF(cx->sb_rxtainted & 1);
201 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
203 (void)SvPOK_only_UTF8(targ);
204 TAINT_IF(cx->sb_rxtainted);
208 LEAVE_SCOPE(cx->sb_oldsave);
210 RETURNOP(pm->op_next);
213 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
216 cx->sb_orig = orig = rx->subbeg;
218 cx->sb_strend = s + (cx->sb_strend - m);
220 cx->sb_m = m = rx->startp[0] + orig;
222 sv_catpvn(dstr, s, m-s);
223 cx->sb_s = rx->endp[0] + orig;
224 { /* Update the pos() information. */
225 SV *sv = cx->sb_targ;
228 if (SvTYPE(sv) < SVt_PVMG)
229 SvUPGRADE(sv, SVt_PVMG);
230 if (!(mg = mg_find(sv, 'g'))) {
231 sv_magic(sv, Nullsv, 'g', Nullch, 0);
232 mg = mg_find(sv, 'g');
239 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
240 rxres_save(&cx->sb_rxres, rx);
241 RETURNOP(pm->op_pmreplstart);
245 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
250 if (!p || p[1] < rx->nparens) {
251 i = 6 + rx->nparens * 2;
259 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
260 RX_MATCH_COPIED_off(rx);
264 *p++ = PTR2UV(rx->subbeg);
265 *p++ = (UV)rx->sublen;
266 for (i = 0; i <= rx->nparens; ++i) {
267 *p++ = (UV)rx->startp[i];
268 *p++ = (UV)rx->endp[i];
273 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
278 if (RX_MATCH_COPIED(rx))
279 Safefree(rx->subbeg);
280 RX_MATCH_COPIED_set(rx, *p);
285 rx->subbeg = INT2PTR(char*,*p++);
286 rx->sublen = (I32)(*p++);
287 for (i = 0; i <= rx->nparens; ++i) {
288 rx->startp[i] = (I32)(*p++);
289 rx->endp[i] = (I32)(*p++);
294 Perl_rxres_free(pTHX_ void **rsp)
299 Safefree(INT2PTR(char*,*p));
307 djSP; dMARK; dORIGMARK;
308 register SV *tmpForm = *++MARK;
320 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
326 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
327 bool item_is_utf = FALSE;
329 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
330 if (SvREADONLY(tmpForm)) {
331 SvREADONLY_off(tmpForm);
332 doparseform(tmpForm);
333 SvREADONLY_on(tmpForm);
336 doparseform(tmpForm);
339 SvPV_force(PL_formtarget, len);
340 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
342 f = SvPV(tmpForm, len);
343 /* need to jump to the next word */
344 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
353 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
354 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
355 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
356 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
357 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
359 case FF_CHECKNL: name = "CHECKNL"; break;
360 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
361 case FF_SPACE: name = "SPACE"; break;
362 case FF_HALFSPACE: name = "HALFSPACE"; break;
363 case FF_ITEM: name = "ITEM"; break;
364 case FF_CHOP: name = "CHOP"; break;
365 case FF_LINEGLOB: name = "LINEGLOB"; break;
366 case FF_NEWLINE: name = "NEWLINE"; break;
367 case FF_MORE: name = "MORE"; break;
368 case FF_LINEMARK: name = "LINEMARK"; break;
369 case FF_END: name = "END"; break;
370 case FF_0DECIMAL: name = "0DECIMAL"; break;
373 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
375 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
403 if (ckWARN(WARN_SYNTAX))
404 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
409 item = s = SvPV(sv, len);
412 itemsize = sv_len_utf8(sv);
413 if (itemsize != len) {
415 if (itemsize > fieldsize) {
416 itemsize = fieldsize;
417 itembytes = itemsize;
418 sv_pos_u2b(sv, &itembytes, 0);
422 send = chophere = s + itembytes;
432 sv_pos_b2u(sv, &itemsize);
437 if (itemsize > fieldsize)
438 itemsize = fieldsize;
439 send = chophere = s + itemsize;
451 item = s = SvPV(sv, len);
454 itemsize = sv_len_utf8(sv);
455 if (itemsize != len) {
457 if (itemsize <= fieldsize) {
458 send = chophere = s + itemsize;
469 itemsize = fieldsize;
470 itembytes = itemsize;
471 sv_pos_u2b(sv, &itembytes, 0);
472 send = chophere = s + itembytes;
473 while (s < send || (s == send && isSPACE(*s))) {
483 if (strchr(PL_chopset, *s))
488 itemsize = chophere - item;
489 sv_pos_b2u(sv, &itemsize);
496 if (itemsize <= fieldsize) {
497 send = chophere = s + itemsize;
508 itemsize = fieldsize;
509 send = chophere = s + itemsize;
510 while (s < send || (s == send && isSPACE(*s))) {
520 if (strchr(PL_chopset, *s))
525 itemsize = chophere - item;
530 arg = fieldsize - itemsize;
539 arg = fieldsize - itemsize;
553 if (UTF8_IS_CONTINUED(*s)) {
554 switch (UTF8SKIP(s)) {
565 if ( !((*t++ = *s++) & ~31) )
573 int ch = *t++ = *s++;
576 if ( !((*t++ = *s++) & ~31) )
585 while (*s && isSPACE(*s))
592 item = s = SvPV(sv, len);
594 item_is_utf = FALSE; /* XXX is this correct? */
606 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
607 sv_catpvn(PL_formtarget, item, itemsize);
608 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
609 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
614 /* If the field is marked with ^ and the value is undefined,
617 if ((arg & 512) && !SvOK(sv)) {
625 /* Formats aren't yet marked for locales, so assume "yes". */
627 STORE_NUMERIC_STANDARD_SET_LOCAL();
628 #if defined(USE_LONG_DOUBLE)
630 sprintf(t, "%#*.*" PERL_PRIfldbl,
631 (int) fieldsize, (int) arg & 255, value);
633 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
638 (int) fieldsize, (int) arg & 255, value);
641 (int) fieldsize, value);
644 RESTORE_NUMERIC_STANDARD();
650 /* If the field is marked with ^ and the value is undefined,
653 if ((arg & 512) && !SvOK(sv)) {
661 /* Formats aren't yet marked for locales, so assume "yes". */
663 STORE_NUMERIC_STANDARD_SET_LOCAL();
664 #if defined(USE_LONG_DOUBLE)
666 sprintf(t, "%#0*.*" PERL_PRIfldbl,
667 (int) fieldsize, (int) arg & 255, value);
668 /* is this legal? I don't have long doubles */
670 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
674 sprintf(t, "%#0*.*f",
675 (int) fieldsize, (int) arg & 255, value);
678 (int) fieldsize, value);
681 RESTORE_NUMERIC_STANDARD();
688 while (t-- > linemark && *t == ' ') ;
696 if (arg) { /* repeat until fields exhausted? */
698 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
699 lines += FmLINES(PL_formtarget);
702 if (strnEQ(linemark, linemark - arg, arg))
703 DIE(aTHX_ "Runaway format");
705 FmLINES(PL_formtarget) = lines;
707 RETURNOP(cLISTOP->op_first);
720 while (*s && isSPACE(*s) && s < send)
724 arg = fieldsize - itemsize;
731 if (strnEQ(s," ",3)) {
732 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
743 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
744 FmLINES(PL_formtarget) += lines;
756 if (PL_stack_base + *PL_markstack_ptr == SP) {
758 if (GIMME_V == G_SCALAR)
759 XPUSHs(sv_2mortal(newSViv(0)));
760 RETURNOP(PL_op->op_next->op_next);
762 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
763 pp_pushmark(); /* push dst */
764 pp_pushmark(); /* push src */
765 ENTER; /* enter outer scope */
768 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
770 ENTER; /* enter inner scope */
773 src = PL_stack_base[*PL_markstack_ptr];
778 if (PL_op->op_type == OP_MAPSTART)
779 pp_pushmark(); /* push top */
780 return ((LOGOP*)PL_op->op_next)->op_other;
785 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
791 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
797 /* first, move source pointer to the next item in the source list */
798 ++PL_markstack_ptr[-1];
800 /* if there are new items, push them into the destination list */
802 /* might need to make room back there first */
803 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
804 /* XXX this implementation is very pessimal because the stack
805 * is repeatedly extended for every set of items. Is possible
806 * to do this without any stack extension or copying at all
807 * by maintaining a separate list over which the map iterates
808 * (like foreach does). --gsar */
810 /* everything in the stack after the destination list moves
811 * towards the end the stack by the amount of room needed */
812 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
814 /* items to shift up (accounting for the moved source pointer) */
815 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
817 /* This optimization is by Ben Tilly and it does
818 * things differently from what Sarathy (gsar)
819 * is describing. The downside of this optimization is
820 * that leaves "holes" (uninitialized and hopefully unused areas)
821 * to the Perl stack, but on the other hand this
822 * shouldn't be a problem. If Sarathy's idea gets
823 * implemented, this optimization should become
824 * irrelevant. --jhi */
826 shift = count; /* Avoid shifting too often --Ben Tilly */
831 PL_markstack_ptr[-1] += shift;
832 *PL_markstack_ptr += shift;
836 /* copy the new items down to the destination list */
837 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
839 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
841 LEAVE; /* exit inner scope */
844 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
847 (void)POPMARK; /* pop top */
848 LEAVE; /* exit outer scope */
849 (void)POPMARK; /* pop src */
850 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
851 (void)POPMARK; /* pop dst */
852 SP = PL_stack_base + POPMARK; /* pop original mark */
853 if (gimme == G_SCALAR) {
857 else if (gimme == G_ARRAY)
864 ENTER; /* enter inner scope */
867 /* set $_ to the new source item */
868 src = PL_stack_base[PL_markstack_ptr[-1]];
872 RETURNOP(cLOGOP->op_other);
878 djSP; dMARK; dORIGMARK;
880 SV **myorigmark = ORIGMARK;
886 OP* nextop = PL_op->op_next;
888 bool hasargs = FALSE;
891 if (gimme != G_ARRAY) {
897 SAVEVPTR(PL_sortcop);
898 if (PL_op->op_flags & OPf_STACKED) {
899 if (PL_op->op_flags & OPf_SPECIAL) {
900 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
901 kid = kUNOP->op_first; /* pass rv2gv */
902 kid = kUNOP->op_first; /* pass leave */
903 PL_sortcop = kid->op_next;
904 stash = CopSTASH(PL_curcop);
907 cv = sv_2cv(*++MARK, &stash, &gv, 0);
908 if (cv && SvPOK(cv)) {
910 char *proto = SvPV((SV*)cv, n_a);
911 if (proto && strEQ(proto, "$$")) {
915 if (!(cv && CvROOT(cv))) {
916 if (cv && CvXSUB(cv)) {
920 SV *tmpstr = sv_newmortal();
921 gv_efullname3(tmpstr, gv, Nullch);
922 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
926 DIE(aTHX_ "Undefined subroutine in sort");
931 PL_sortcop = (OP*)cv;
933 PL_sortcop = CvSTART(cv);
934 SAVEVPTR(CvROOT(cv)->op_ppaddr);
935 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
938 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
944 stash = CopSTASH(PL_curcop);
948 while (MARK < SP) { /* This may or may not shift down one here. */
950 if ((*up = *++MARK)) { /* Weed out nulls. */
952 if (!PL_sortcop && !SvPOK(*up)) {
957 (void)sv_2pv(*up, &n_a);
962 max = --up - myorigmark;
967 bool oldcatch = CATCH_GET;
973 PUSHSTACKi(PERLSI_SORT);
974 if (!hasargs && !is_xsub) {
975 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
976 SAVESPTR(PL_firstgv);
977 SAVESPTR(PL_secondgv);
978 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
979 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
980 PL_sortstash = stash;
983 sv_lock((SV *)PL_firstgv);
984 sv_lock((SV *)PL_secondgv);
986 SAVESPTR(GvSV(PL_firstgv));
987 SAVESPTR(GvSV(PL_secondgv));
990 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
991 if (!(PL_op->op_flags & OPf_SPECIAL)) {
992 cx->cx_type = CXt_SUB;
993 cx->blk_gimme = G_SCALAR;
996 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
998 PL_sortcxix = cxstack_ix;
1000 if (hasargs && !is_xsub) {
1001 /* This is mostly copied from pp_entersub */
1002 AV *av = (AV*)PL_curpad[0];
1005 cx->blk_sub.savearray = GvAV(PL_defgv);
1006 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1007 #endif /* USE_THREADS */
1008 cx->blk_sub.oldcurpad = PL_curpad;
1009 cx->blk_sub.argarray = av;
1011 qsortsv((myorigmark+1), max,
1012 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1014 POPBLOCK(cx,PL_curpm);
1015 PL_stack_sp = newsp;
1017 CATCH_SET(oldcatch);
1022 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1023 qsortsv(ORIGMARK+1, max,
1024 (PL_op->op_private & OPpSORT_NUMERIC)
1025 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1026 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1027 : ( overloading ? amagic_ncmp : sv_ncmp))
1028 : ( (PL_op->op_private & OPpLOCALE)
1031 : sv_cmp_locale_static)
1032 : ( overloading ? amagic_cmp : sv_cmp_static)));
1033 if (PL_op->op_private & OPpSORT_REVERSE) {
1034 SV **p = ORIGMARK+1;
1035 SV **q = ORIGMARK+max;
1045 PL_stack_sp = ORIGMARK + max;
1053 if (GIMME == G_ARRAY)
1055 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1056 return cLOGOP->op_other;
1065 if (GIMME == G_ARRAY) {
1066 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1070 SV *targ = PAD_SV(PL_op->op_targ);
1073 if (PL_op->op_private & OPpFLIP_LINENUM) {
1075 flip = PL_last_in_gv
1076 && (gp_io = GvIOp(PL_last_in_gv))
1077 && SvIV(sv) == (IV)IoLINES(gp_io);
1082 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1083 if (PL_op->op_flags & OPf_SPECIAL) {
1091 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1104 if (GIMME == G_ARRAY) {
1110 if (SvGMAGICAL(left))
1112 if (SvGMAGICAL(right))
1115 if (SvNIOKp(left) || !SvPOKp(left) ||
1116 SvNIOKp(right) || !SvPOKp(right) ||
1117 (looks_like_number(left) && *SvPVX(left) != '0' &&
1118 looks_like_number(right) && *SvPVX(right) != '0'))
1120 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1121 DIE(aTHX_ "Range iterator outside integer range");
1132 sv = sv_2mortal(newSViv(i++));
1137 SV *final = sv_mortalcopy(right);
1139 char *tmps = SvPV(final, len);
1141 sv = sv_mortalcopy(left);
1143 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1145 if (strEQ(SvPVX(sv),tmps))
1147 sv = sv_2mortal(newSVsv(sv));
1154 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1156 if ((PL_op->op_private & OPpFLIP_LINENUM)
1157 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1159 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1160 sv_catpv(targ, "E0");
1171 S_dopoptolabel(pTHX_ char *label)
1174 register PERL_CONTEXT *cx;
1176 for (i = cxstack_ix; i >= 0; i--) {
1178 switch (CxTYPE(cx)) {
1180 if (ckWARN(WARN_EXITING))
1181 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1182 PL_op_name[PL_op->op_type]);
1185 if (ckWARN(WARN_EXITING))
1186 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1187 PL_op_name[PL_op->op_type]);
1190 if (ckWARN(WARN_EXITING))
1191 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1192 PL_op_name[PL_op->op_type]);
1195 if (ckWARN(WARN_EXITING))
1196 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1197 PL_op_name[PL_op->op_type]);
1200 if (ckWARN(WARN_EXITING))
1201 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1202 PL_op_name[PL_op->op_type]);
1205 if (!cx->blk_loop.label ||
1206 strNE(label, cx->blk_loop.label) ) {
1207 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1208 (long)i, cx->blk_loop.label));
1211 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1219 Perl_dowantarray(pTHX)
1221 I32 gimme = block_gimme();
1222 return (gimme == G_VOID) ? G_SCALAR : gimme;
1226 Perl_block_gimme(pTHX)
1230 cxix = dopoptosub(cxstack_ix);
1234 switch (cxstack[cxix].blk_gimme) {
1242 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1249 Perl_is_lvalue_sub(pTHX)
1253 cxix = dopoptosub(cxstack_ix);
1254 assert(cxix >= 0); /* We should only be called from inside subs */
1256 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1257 return cxstack[cxix].blk_sub.lval;
1263 S_dopoptosub(pTHX_ I32 startingblock)
1265 return dopoptosub_at(cxstack, startingblock);
1269 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1272 register PERL_CONTEXT *cx;
1273 for (i = startingblock; i >= 0; i--) {
1275 switch (CxTYPE(cx)) {
1281 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1289 S_dopoptoeval(pTHX_ I32 startingblock)
1292 register PERL_CONTEXT *cx;
1293 for (i = startingblock; i >= 0; i--) {
1295 switch (CxTYPE(cx)) {
1299 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1307 S_dopoptoloop(pTHX_ I32 startingblock)
1310 register PERL_CONTEXT *cx;
1311 for (i = startingblock; i >= 0; i--) {
1313 switch (CxTYPE(cx)) {
1315 if (ckWARN(WARN_EXITING))
1316 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1317 PL_op_name[PL_op->op_type]);
1320 if (ckWARN(WARN_EXITING))
1321 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1322 PL_op_name[PL_op->op_type]);
1325 if (ckWARN(WARN_EXITING))
1326 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1327 PL_op_name[PL_op->op_type]);
1330 if (ckWARN(WARN_EXITING))
1331 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1332 PL_op_name[PL_op->op_type]);
1335 if (ckWARN(WARN_EXITING))
1336 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1337 PL_op_name[PL_op->op_type]);
1340 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1348 Perl_dounwind(pTHX_ I32 cxix)
1350 register PERL_CONTEXT *cx;
1353 while (cxstack_ix > cxix) {
1355 cx = &cxstack[cxstack_ix];
1356 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1357 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1358 /* Note: we don't need to restore the base context info till the end. */
1359 switch (CxTYPE(cx)) {
1362 continue; /* not break */
1384 * Closures mentioned at top level of eval cannot be referenced
1385 * again, and their presence indirectly causes a memory leak.
1386 * (Note that the fact that compcv and friends are still set here
1387 * is, AFAIK, an accident.) --Chip
1389 * XXX need to get comppad et al from eval's cv rather than
1390 * relying on the incidental global values.
1393 S_free_closures(pTHX)
1395 SV **svp = AvARRAY(PL_comppad_name);
1397 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1399 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1401 svp[ix] = &PL_sv_undef;
1405 SvREFCNT_dec(CvOUTSIDE(sv));
1406 CvOUTSIDE(sv) = Nullcv;
1419 Perl_qerror(pTHX_ SV *err)
1422 sv_catsv(ERRSV, err);
1424 sv_catsv(PL_errors, err);
1426 Perl_warn(aTHX_ "%"SVf, err);
1431 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1436 register PERL_CONTEXT *cx;
1441 if (PL_in_eval & EVAL_KEEPERR) {
1442 static char prefix[] = "\t(in cleanup) ";
1447 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1450 if (*e != *message || strNE(e,message))
1454 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1455 sv_catpvn(err, prefix, sizeof(prefix)-1);
1456 sv_catpvn(err, message, msglen);
1457 if (ckWARN(WARN_MISC)) {
1458 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1459 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1464 sv_setpvn(ERRSV, message, msglen);
1465 if (PL_hints & HINT_UTF8)
1472 message = SvPVx(ERRSV, msglen);
1474 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1475 && PL_curstackinfo->si_prev)
1484 if (cxix < cxstack_ix)
1487 POPBLOCK(cx,PL_curpm);
1488 if (CxTYPE(cx) != CXt_EVAL) {
1489 PerlIO_write(Perl_error_log, "panic: die ", 11);
1490 PerlIO_write(Perl_error_log, message, msglen);
1495 if (gimme == G_SCALAR)
1496 *++newsp = &PL_sv_undef;
1497 PL_stack_sp = newsp;
1501 /* LEAVE could clobber PL_curcop (see save_re_context())
1502 * XXX it might be better to find a way to avoid messing with
1503 * PL_curcop in save_re_context() instead, but this is a more
1504 * minimal fix --GSAR */
1505 PL_curcop = cx->blk_oldcop;
1507 if (optype == OP_REQUIRE) {
1508 char* msg = SvPVx(ERRSV, n_a);
1509 DIE(aTHX_ "%sCompilation failed in require",
1510 *msg ? msg : "Unknown error\n");
1512 return pop_return();
1516 message = SvPVx(ERRSV, msglen);
1519 /* SFIO can really mess with your errno */
1522 PerlIO *serr = Perl_error_log;
1524 PerlIO_write(serr, message, msglen);
1525 (void)PerlIO_flush(serr);
1538 if (SvTRUE(left) != SvTRUE(right))
1550 RETURNOP(cLOGOP->op_other);
1559 RETURNOP(cLOGOP->op_other);
1565 register I32 cxix = dopoptosub(cxstack_ix);
1566 register PERL_CONTEXT *cx;
1567 register PERL_CONTEXT *ccstack = cxstack;
1568 PERL_SI *top_si = PL_curstackinfo;
1579 /* we may be in a higher stacklevel, so dig down deeper */
1580 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1581 top_si = top_si->si_prev;
1582 ccstack = top_si->si_cxstack;
1583 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1586 if (GIMME != G_ARRAY)
1590 if (PL_DBsub && cxix >= 0 &&
1591 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1595 cxix = dopoptosub_at(ccstack, cxix - 1);
1598 cx = &ccstack[cxix];
1599 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1600 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1601 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1602 field below is defined for any cx. */
1603 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1604 cx = &ccstack[dbcxix];
1607 stashname = CopSTASHPV(cx->blk_oldcop);
1608 if (GIMME != G_ARRAY) {
1610 PUSHs(&PL_sv_undef);
1613 sv_setpv(TARG, stashname);
1620 PUSHs(&PL_sv_undef);
1622 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1623 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1624 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1627 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1628 /* So is ccstack[dbcxix]. */
1630 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1631 PUSHs(sv_2mortal(sv));
1632 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1635 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1636 PUSHs(sv_2mortal(newSViv(0)));
1638 gimme = (I32)cx->blk_gimme;
1639 if (gimme == G_VOID)
1640 PUSHs(&PL_sv_undef);
1642 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1643 if (CxTYPE(cx) == CXt_EVAL) {
1645 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1646 PUSHs(cx->blk_eval.cur_text);
1650 else if (cx->blk_eval.old_namesv) {
1651 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1654 /* eval BLOCK (try blocks have old_namesv == 0) */
1656 PUSHs(&PL_sv_undef);
1657 PUSHs(&PL_sv_undef);
1661 PUSHs(&PL_sv_undef);
1662 PUSHs(&PL_sv_undef);
1664 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1665 && CopSTASH_eq(PL_curcop, PL_debstash))
1667 AV *ary = cx->blk_sub.argarray;
1668 int off = AvARRAY(ary) - AvALLOC(ary);
1672 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1675 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1678 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1679 av_extend(PL_dbargs, AvFILLp(ary) + off);
1680 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1681 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1683 /* XXX only hints propagated via op_private are currently
1684 * visible (others are not easily accessible, since they
1685 * use the global PL_hints) */
1686 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1687 HINT_PRIVATE_MASK)));
1690 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1692 if (old_warnings == pWARN_NONE ||
1693 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1694 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1695 else if (old_warnings == pWARN_ALL ||
1696 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1697 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1699 mask = newSVsv(old_warnings);
1700 PUSHs(sv_2mortal(mask));
1715 sv_reset(tmps, CopSTASH(PL_curcop));
1727 PL_curcop = (COP*)PL_op;
1728 TAINT_NOT; /* Each statement is presumed innocent */
1729 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1732 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1736 register PERL_CONTEXT *cx;
1737 I32 gimme = G_ARRAY;
1744 DIE(aTHX_ "No DB::DB routine defined");
1746 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1758 push_return(PL_op->op_next);
1759 PUSHBLOCK(cx, CXt_SUB, SP);
1762 (void)SvREFCNT_inc(cv);
1763 SAVEVPTR(PL_curpad);
1764 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1765 RETURNOP(CvSTART(cv));
1779 register PERL_CONTEXT *cx;
1780 I32 gimme = GIMME_V;
1782 U32 cxtype = CXt_LOOP;
1791 if (PL_op->op_flags & OPf_SPECIAL) {
1792 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1793 SAVEGENERICSV(*svp);
1797 #endif /* USE_THREADS */
1798 if (PL_op->op_targ) {
1799 #ifndef USE_ITHREADS
1800 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1803 SAVEPADSV(PL_op->op_targ);
1804 iterdata = (void*)PL_op->op_targ;
1805 cxtype |= CXp_PADVAR;
1810 svp = &GvSV(gv); /* symbol table variable */
1811 SAVEGENERICSV(*svp);
1814 iterdata = (void*)gv;
1820 PUSHBLOCK(cx, cxtype, SP);
1822 PUSHLOOP(cx, iterdata, MARK);
1824 PUSHLOOP(cx, svp, MARK);
1826 if (PL_op->op_flags & OPf_STACKED) {
1827 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1828 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1830 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1831 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1832 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1833 looks_like_number((SV*)cx->blk_loop.iterary) &&
1834 *SvPVX(cx->blk_loop.iterary) != '0'))
1836 if (SvNV(sv) < IV_MIN ||
1837 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1838 DIE(aTHX_ "Range iterator outside integer range");
1839 cx->blk_loop.iterix = SvIV(sv);
1840 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1843 cx->blk_loop.iterlval = newSVsv(sv);
1847 cx->blk_loop.iterary = PL_curstack;
1848 AvFILLp(PL_curstack) = SP - PL_stack_base;
1849 cx->blk_loop.iterix = MARK - PL_stack_base;
1858 register PERL_CONTEXT *cx;
1859 I32 gimme = GIMME_V;
1865 PUSHBLOCK(cx, CXt_LOOP, SP);
1866 PUSHLOOP(cx, 0, SP);
1874 register PERL_CONTEXT *cx;
1882 newsp = PL_stack_base + cx->blk_loop.resetsp;
1885 if (gimme == G_VOID)
1887 else if (gimme == G_SCALAR) {
1889 *++newsp = sv_mortalcopy(*SP);
1891 *++newsp = &PL_sv_undef;
1895 *++newsp = sv_mortalcopy(*++mark);
1896 TAINT_NOT; /* Each item is independent */
1902 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1903 PL_curpm = newpm; /* ... and pop $1 et al */
1915 register PERL_CONTEXT *cx;
1916 bool popsub2 = FALSE;
1917 bool clear_errsv = FALSE;
1924 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1925 if (cxstack_ix == PL_sortcxix
1926 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1928 if (cxstack_ix > PL_sortcxix)
1929 dounwind(PL_sortcxix);
1930 AvARRAY(PL_curstack)[1] = *SP;
1931 PL_stack_sp = PL_stack_base + 1;
1936 cxix = dopoptosub(cxstack_ix);
1938 DIE(aTHX_ "Can't return outside a subroutine");
1939 if (cxix < cxstack_ix)
1943 switch (CxTYPE(cx)) {
1948 if (!(PL_in_eval & EVAL_KEEPERR))
1953 if (AvFILLp(PL_comppad_name) >= 0)
1956 if (optype == OP_REQUIRE &&
1957 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1959 /* Unassume the success we assumed earlier. */
1960 SV *nsv = cx->blk_eval.old_namesv;
1961 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1962 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1969 DIE(aTHX_ "panic: return");
1973 if (gimme == G_SCALAR) {
1976 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1978 *++newsp = SvREFCNT_inc(*SP);
1983 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1985 *++newsp = sv_mortalcopy(sv);
1990 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1993 *++newsp = sv_mortalcopy(*SP);
1996 *++newsp = &PL_sv_undef;
1998 else if (gimme == G_ARRAY) {
1999 while (++MARK <= SP) {
2000 *++newsp = (popsub2 && SvTEMP(*MARK))
2001 ? *MARK : sv_mortalcopy(*MARK);
2002 TAINT_NOT; /* Each item is independent */
2005 PL_stack_sp = newsp;
2007 /* Stack values are safe: */
2009 POPSUB(cx,sv); /* release CV and @_ ... */
2013 PL_curpm = newpm; /* ... and pop $1 et al */
2019 return pop_return();
2026 register PERL_CONTEXT *cx;
2036 if (PL_op->op_flags & OPf_SPECIAL) {
2037 cxix = dopoptoloop(cxstack_ix);
2039 DIE(aTHX_ "Can't \"last\" outside a loop block");
2042 cxix = dopoptolabel(cPVOP->op_pv);
2044 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2046 if (cxix < cxstack_ix)
2051 switch (CxTYPE(cx)) {
2054 newsp = PL_stack_base + cx->blk_loop.resetsp;
2055 nextop = cx->blk_loop.last_op->op_next;
2059 nextop = pop_return();
2063 nextop = pop_return();
2067 nextop = pop_return();
2070 DIE(aTHX_ "panic: last");
2074 if (gimme == G_SCALAR) {
2076 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2077 ? *SP : sv_mortalcopy(*SP);
2079 *++newsp = &PL_sv_undef;
2081 else if (gimme == G_ARRAY) {
2082 while (++MARK <= SP) {
2083 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2084 ? *MARK : sv_mortalcopy(*MARK);
2085 TAINT_NOT; /* Each item is independent */
2091 /* Stack values are safe: */
2094 POPLOOP(cx); /* release loop vars ... */
2098 POPSUB(cx,sv); /* release CV and @_ ... */
2101 PL_curpm = newpm; /* ... and pop $1 et al */
2111 register PERL_CONTEXT *cx;
2114 if (PL_op->op_flags & OPf_SPECIAL) {
2115 cxix = dopoptoloop(cxstack_ix);
2117 DIE(aTHX_ "Can't \"next\" outside a loop block");
2120 cxix = dopoptolabel(cPVOP->op_pv);
2122 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2124 if (cxix < cxstack_ix)
2127 /* clear off anything above the scope we're re-entering, but
2128 * save the rest until after a possible continue block */
2129 inner = PL_scopestack_ix;
2131 if (PL_scopestack_ix < inner)
2132 leave_scope(PL_scopestack[PL_scopestack_ix]);
2133 return cx->blk_loop.next_op;
2139 register PERL_CONTEXT *cx;
2142 if (PL_op->op_flags & OPf_SPECIAL) {
2143 cxix = dopoptoloop(cxstack_ix);
2145 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2148 cxix = dopoptolabel(cPVOP->op_pv);
2150 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2152 if (cxix < cxstack_ix)
2156 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2157 LEAVE_SCOPE(oldsave);
2158 return cx->blk_loop.redo_op;
2162 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2166 static char too_deep[] = "Target of goto is too deeply nested";
2169 Perl_croak(aTHX_ too_deep);
2170 if (o->op_type == OP_LEAVE ||
2171 o->op_type == OP_SCOPE ||
2172 o->op_type == OP_LEAVELOOP ||
2173 o->op_type == OP_LEAVETRY)
2175 *ops++ = cUNOPo->op_first;
2177 Perl_croak(aTHX_ too_deep);
2180 if (o->op_flags & OPf_KIDS) {
2181 /* First try all the kids at this level, since that's likeliest. */
2182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2183 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2184 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2187 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2188 if (kid == PL_lastgotoprobe)
2190 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2192 (ops[-1]->op_type != OP_NEXTSTATE &&
2193 ops[-1]->op_type != OP_DBSTATE)))
2195 if ((o = dofindlabel(kid, label, ops, oplimit)))
2214 register PERL_CONTEXT *cx;
2215 #define GOTO_DEPTH 64
2216 OP *enterops[GOTO_DEPTH];
2218 int do_dump = (PL_op->op_type == OP_DUMP);
2219 static char must_have_label[] = "goto must have label";
2222 if (PL_op->op_flags & OPf_STACKED) {
2226 /* This egregious kludge implements goto &subroutine */
2227 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2229 register PERL_CONTEXT *cx;
2230 CV* cv = (CV*)SvRV(sv);
2236 if (!CvROOT(cv) && !CvXSUB(cv)) {
2241 /* autoloaded stub? */
2242 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2244 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2245 GvNAMELEN(gv), FALSE);
2246 if (autogv && (cv = GvCV(autogv)))
2248 tmpstr = sv_newmortal();
2249 gv_efullname3(tmpstr, gv, Nullch);
2250 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2252 DIE(aTHX_ "Goto undefined subroutine");
2255 /* First do some returnish stuff. */
2256 cxix = dopoptosub(cxstack_ix);
2258 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2259 if (cxix < cxstack_ix)
2262 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2263 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2265 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2266 /* put @_ back onto stack */
2267 AV* av = cx->blk_sub.argarray;
2269 items = AvFILLp(av) + 1;
2271 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2272 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2273 PL_stack_sp += items;
2275 SvREFCNT_dec(GvAV(PL_defgv));
2276 GvAV(PL_defgv) = cx->blk_sub.savearray;
2277 #endif /* USE_THREADS */
2278 /* abandon @_ if it got reified */
2280 (void)sv_2mortal((SV*)av); /* delay until return */
2282 av_extend(av, items-1);
2283 AvFLAGS(av) = AVf_REIFY;
2284 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2287 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2290 av = (AV*)PL_curpad[0];
2292 av = GvAV(PL_defgv);
2294 items = AvFILLp(av) + 1;
2296 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2297 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2298 PL_stack_sp += items;
2300 if (CxTYPE(cx) == CXt_SUB &&
2301 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2302 SvREFCNT_dec(cx->blk_sub.cv);
2303 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2304 LEAVE_SCOPE(oldsave);
2306 /* Now do some callish stuff. */
2309 #ifdef PERL_XSUB_OLDSTYLE
2310 if (CvOLDSTYLE(cv)) {
2311 I32 (*fp3)(int,int,int);
2316 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2317 items = (*fp3)(CvXSUBANY(cv).any_i32,
2318 mark - PL_stack_base + 1,
2320 SP = PL_stack_base + items;
2323 #endif /* PERL_XSUB_OLDSTYLE */
2328 PL_stack_sp--; /* There is no cv arg. */
2329 /* Push a mark for the start of arglist */
2331 (void)(*CvXSUB(cv))(aTHXo_ cv);
2332 /* Pop the current context like a decent sub should */
2333 POPBLOCK(cx, PL_curpm);
2334 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2337 return pop_return();
2340 AV* padlist = CvPADLIST(cv);
2341 SV** svp = AvARRAY(padlist);
2342 if (CxTYPE(cx) == CXt_EVAL) {
2343 PL_in_eval = cx->blk_eval.old_in_eval;
2344 PL_eval_root = cx->blk_eval.old_eval_root;
2345 cx->cx_type = CXt_SUB;
2346 cx->blk_sub.hasargs = 0;
2348 cx->blk_sub.cv = cv;
2349 cx->blk_sub.olddepth = CvDEPTH(cv);
2351 if (CvDEPTH(cv) < 2)
2352 (void)SvREFCNT_inc(cv);
2353 else { /* save temporaries on recursion? */
2354 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2355 sub_crush_depth(cv);
2356 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2357 AV *newpad = newAV();
2358 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2359 I32 ix = AvFILLp((AV*)svp[1]);
2360 I32 names_fill = AvFILLp((AV*)svp[0]);
2361 svp = AvARRAY(svp[0]);
2362 for ( ;ix > 0; ix--) {
2363 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2364 char *name = SvPVX(svp[ix]);
2365 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2368 /* outer lexical or anon code */
2369 av_store(newpad, ix,
2370 SvREFCNT_inc(oldpad[ix]) );
2372 else { /* our own lexical */
2374 av_store(newpad, ix, sv = (SV*)newAV());
2375 else if (*name == '%')
2376 av_store(newpad, ix, sv = (SV*)newHV());
2378 av_store(newpad, ix, sv = NEWSV(0,0));
2382 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2383 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2386 av_store(newpad, ix, sv = NEWSV(0,0));
2390 if (cx->blk_sub.hasargs) {
2393 av_store(newpad, 0, (SV*)av);
2394 AvFLAGS(av) = AVf_REIFY;
2396 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2397 AvFILLp(padlist) = CvDEPTH(cv);
2398 svp = AvARRAY(padlist);
2402 if (!cx->blk_sub.hasargs) {
2403 AV* av = (AV*)PL_curpad[0];
2405 items = AvFILLp(av) + 1;
2407 /* Mark is at the end of the stack. */
2409 Copy(AvARRAY(av), SP + 1, items, SV*);
2414 #endif /* USE_THREADS */
2415 SAVEVPTR(PL_curpad);
2416 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2418 if (cx->blk_sub.hasargs)
2419 #endif /* USE_THREADS */
2421 AV* av = (AV*)PL_curpad[0];
2425 cx->blk_sub.savearray = GvAV(PL_defgv);
2426 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2427 #endif /* USE_THREADS */
2428 cx->blk_sub.oldcurpad = PL_curpad;
2429 cx->blk_sub.argarray = av;
2432 if (items >= AvMAX(av) + 1) {
2434 if (AvARRAY(av) != ary) {
2435 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2436 SvPVX(av) = (char*)ary;
2438 if (items >= AvMAX(av) + 1) {
2439 AvMAX(av) = items - 1;
2440 Renew(ary,items+1,SV*);
2442 SvPVX(av) = (char*)ary;
2445 Copy(mark,AvARRAY(av),items,SV*);
2446 AvFILLp(av) = items - 1;
2447 assert(!AvREAL(av));
2454 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2456 * We do not care about using sv to call CV;
2457 * it's for informational purposes only.
2459 SV *sv = GvSV(PL_DBsub);
2462 if (PERLDB_SUB_NN) {
2463 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2466 gv_efullname3(sv, CvGV(cv), Nullch);
2469 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2470 PUSHMARK( PL_stack_sp );
2471 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2475 RETURNOP(CvSTART(cv));
2479 label = SvPV(sv,n_a);
2480 if (!(do_dump || *label))
2481 DIE(aTHX_ must_have_label);
2484 else if (PL_op->op_flags & OPf_SPECIAL) {
2486 DIE(aTHX_ must_have_label);
2489 label = cPVOP->op_pv;
2491 if (label && *label) {
2496 PL_lastgotoprobe = 0;
2498 for (ix = cxstack_ix; ix >= 0; ix--) {
2500 switch (CxTYPE(cx)) {
2502 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2505 gotoprobe = cx->blk_oldcop->op_sibling;
2511 gotoprobe = cx->blk_oldcop->op_sibling;
2513 gotoprobe = PL_main_root;
2516 if (CvDEPTH(cx->blk_sub.cv)) {
2517 gotoprobe = CvROOT(cx->blk_sub.cv);
2523 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2526 DIE(aTHX_ "panic: goto");
2527 gotoprobe = PL_main_root;
2531 retop = dofindlabel(gotoprobe, label,
2532 enterops, enterops + GOTO_DEPTH);
2536 PL_lastgotoprobe = gotoprobe;
2539 DIE(aTHX_ "Can't find label %s", label);
2541 /* pop unwanted frames */
2543 if (ix < cxstack_ix) {
2550 oldsave = PL_scopestack[PL_scopestack_ix];
2551 LEAVE_SCOPE(oldsave);
2554 /* push wanted frames */
2556 if (*enterops && enterops[1]) {
2558 for (ix = 1; enterops[ix]; ix++) {
2559 PL_op = enterops[ix];
2560 /* Eventually we may want to stack the needed arguments
2561 * for each op. For now, we punt on the hard ones. */
2562 if (PL_op->op_type == OP_ENTERITER)
2563 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2564 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2572 if (!retop) retop = PL_main_start;
2574 PL_restartop = retop;
2575 PL_do_undump = TRUE;
2579 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2580 PL_do_undump = FALSE;
2596 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2600 PL_exit_flags |= PERL_EXIT_EXPECTED;
2602 PUSHs(&PL_sv_undef);
2610 NV value = SvNVx(GvSV(cCOP->cop_gv));
2611 register I32 match = I_32(value);
2614 if (((NV)match) > value)
2615 --match; /* was fractional--truncate other way */
2617 match -= cCOP->uop.scop.scop_offset;
2620 else if (match > cCOP->uop.scop.scop_max)
2621 match = cCOP->uop.scop.scop_max;
2622 PL_op = cCOP->uop.scop.scop_next[match];
2632 PL_op = PL_op->op_next; /* can't assume anything */
2635 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2636 match -= cCOP->uop.scop.scop_offset;
2639 else if (match > cCOP->uop.scop.scop_max)
2640 match = cCOP->uop.scop.scop_max;
2641 PL_op = cCOP->uop.scop.scop_next[match];
2650 S_save_lines(pTHX_ AV *array, SV *sv)
2652 register char *s = SvPVX(sv);
2653 register char *send = SvPVX(sv) + SvCUR(sv);
2655 register I32 line = 1;
2657 while (s && s < send) {
2658 SV *tmpstr = NEWSV(85,0);
2660 sv_upgrade(tmpstr, SVt_PVMG);
2661 t = strchr(s, '\n');
2667 sv_setpvn(tmpstr, s, t - s);
2668 av_store(array, line++, tmpstr);
2673 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2675 S_docatch_body(pTHX_ va_list args)
2677 return docatch_body();
2682 S_docatch_body(pTHX)
2689 S_docatch(pTHX_ OP *o)
2693 volatile PERL_SI *cursi = PL_curstackinfo;
2697 assert(CATCH_GET == TRUE);
2700 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2702 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2708 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2714 if (PL_restartop && cursi == PL_curstackinfo) {
2715 PL_op = PL_restartop;
2732 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2733 /* sv Text to convert to OP tree. */
2734 /* startop op_free() this to undo. */
2735 /* code Short string id of the caller. */
2737 dSP; /* Make POPBLOCK work. */
2740 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2744 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2745 char *tmpbuf = tbuf;
2751 /* switch to eval mode */
2753 if (PL_curcop == &PL_compiling) {
2754 SAVECOPSTASH_FREE(&PL_compiling);
2755 CopSTASH_set(&PL_compiling, PL_curstash);
2757 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2758 SV *sv = sv_newmortal();
2759 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2760 code, (unsigned long)++PL_evalseq,
2761 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2765 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2766 SAVECOPFILE_FREE(&PL_compiling);
2767 CopFILE_set(&PL_compiling, tmpbuf+2);
2768 SAVECOPLINE(&PL_compiling);
2769 CopLINE_set(&PL_compiling, 1);
2770 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2771 deleting the eval's FILEGV from the stash before gv_check() runs
2772 (i.e. before run-time proper). To work around the coredump that
2773 ensues, we always turn GvMULTI_on for any globals that were
2774 introduced within evals. See force_ident(). GSAR 96-10-12 */
2775 safestr = savepv(tmpbuf);
2776 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2778 #ifdef OP_IN_REGISTER
2783 PL_hints &= HINT_UTF8;
2786 PL_op->op_type = OP_ENTEREVAL;
2787 PL_op->op_flags = 0; /* Avoid uninit warning. */
2788 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2789 PUSHEVAL(cx, 0, Nullgv);
2790 rop = doeval(G_SCALAR, startop);
2791 POPBLOCK(cx,PL_curpm);
2794 (*startop)->op_type = OP_NULL;
2795 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2797 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2799 if (PL_curcop == &PL_compiling)
2800 PL_compiling.op_private = PL_hints;
2801 #ifdef OP_IN_REGISTER
2807 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2809 S_doeval(pTHX_ int gimme, OP** startop)
2817 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2818 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2823 /* set up a scratch pad */
2826 SAVEVPTR(PL_curpad);
2827 SAVESPTR(PL_comppad);
2828 SAVESPTR(PL_comppad_name);
2829 SAVEI32(PL_comppad_name_fill);
2830 SAVEI32(PL_min_intro_pending);
2831 SAVEI32(PL_max_intro_pending);
2834 for (i = cxstack_ix - 1; i >= 0; i--) {
2835 PERL_CONTEXT *cx = &cxstack[i];
2836 if (CxTYPE(cx) == CXt_EVAL)
2838 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2839 caller = cx->blk_sub.cv;
2844 SAVESPTR(PL_compcv);
2845 PL_compcv = (CV*)NEWSV(1104,0);
2846 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2847 CvEVAL_on(PL_compcv);
2849 CvOWNER(PL_compcv) = 0;
2850 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2851 MUTEX_INIT(CvMUTEXP(PL_compcv));
2852 #endif /* USE_THREADS */
2854 PL_comppad = newAV();
2855 av_push(PL_comppad, Nullsv);
2856 PL_curpad = AvARRAY(PL_comppad);
2857 PL_comppad_name = newAV();
2858 PL_comppad_name_fill = 0;
2859 PL_min_intro_pending = 0;
2862 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2863 PL_curpad[0] = (SV*)newAV();
2864 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2865 #endif /* USE_THREADS */
2867 comppadlist = newAV();
2868 AvREAL_off(comppadlist);
2869 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2870 av_store(comppadlist, 1, (SV*)PL_comppad);
2871 CvPADLIST(PL_compcv) = comppadlist;
2874 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2876 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2879 SAVEFREESV(PL_compcv);
2881 /* make sure we compile in the right package */
2883 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2884 SAVESPTR(PL_curstash);
2885 PL_curstash = CopSTASH(PL_curcop);
2887 SAVESPTR(PL_beginav);
2888 PL_beginav = newAV();
2889 SAVEFREESV(PL_beginav);
2890 SAVEI32(PL_error_count);
2892 /* try to compile it */
2894 PL_eval_root = Nullop;
2896 PL_curcop = &PL_compiling;
2897 PL_curcop->cop_arybase = 0;
2898 SvREFCNT_dec(PL_rs);
2899 PL_rs = newSVpvn("\n", 1);
2900 if (saveop && saveop->op_flags & OPf_SPECIAL)
2901 PL_in_eval |= EVAL_KEEPERR;
2904 if (yyparse() || PL_error_count || !PL_eval_root) {
2908 I32 optype = 0; /* Might be reset by POPEVAL. */
2913 op_free(PL_eval_root);
2914 PL_eval_root = Nullop;
2916 SP = PL_stack_base + POPMARK; /* pop original mark */
2918 POPBLOCK(cx,PL_curpm);
2924 if (optype == OP_REQUIRE) {
2925 char* msg = SvPVx(ERRSV, n_a);
2926 DIE(aTHX_ "%sCompilation failed in require",
2927 *msg ? msg : "Unknown error\n");
2930 char* msg = SvPVx(ERRSV, n_a);
2932 POPBLOCK(cx,PL_curpm);
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
2937 SvREFCNT_dec(PL_rs);
2938 PL_rs = SvREFCNT_inc(PL_nrs);
2940 MUTEX_LOCK(&PL_eval_mutex);
2942 COND_SIGNAL(&PL_eval_cond);
2943 MUTEX_UNLOCK(&PL_eval_mutex);
2944 #endif /* USE_THREADS */
2947 SvREFCNT_dec(PL_rs);
2948 PL_rs = SvREFCNT_inc(PL_nrs);
2949 CopLINE_set(&PL_compiling, 0);
2951 *startop = PL_eval_root;
2952 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2953 CvOUTSIDE(PL_compcv) = Nullcv;
2955 SAVEFREEOP(PL_eval_root);
2957 scalarvoid(PL_eval_root);
2958 else if (gimme & G_ARRAY)
2961 scalar(PL_eval_root);
2963 DEBUG_x(dump_eval());
2965 /* Register with debugger: */
2966 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2967 CV *cv = get_cv("DB::postponed", FALSE);
2971 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2973 call_sv((SV*)cv, G_DISCARD);
2977 /* compiled okay, so do it */
2979 CvDEPTH(PL_compcv) = 1;
2980 SP = PL_stack_base + POPMARK; /* pop original mark */
2981 PL_op = saveop; /* The caller may need it. */
2982 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2984 MUTEX_LOCK(&PL_eval_mutex);
2986 COND_SIGNAL(&PL_eval_cond);
2987 MUTEX_UNLOCK(&PL_eval_mutex);
2988 #endif /* USE_THREADS */
2990 RETURNOP(PL_eval_start);
2994 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2996 STRLEN namelen = strlen(name);
2999 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3000 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3001 char *pmc = SvPV_nolen(pmcsv);
3004 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3005 fp = PerlIO_open(name, mode);
3008 if (PerlLIO_stat(name, &pmstat) < 0 ||
3009 pmstat.st_mtime < pmcstat.st_mtime)
3011 fp = PerlIO_open(pmc, mode);
3014 fp = PerlIO_open(name, mode);
3017 SvREFCNT_dec(pmcsv);
3020 fp = PerlIO_open(name, mode);
3028 register PERL_CONTEXT *cx;
3033 SV *namesv = Nullsv;
3035 I32 gimme = G_SCALAR;
3036 PerlIO *tryrsfp = 0;
3038 int filter_has_file = 0;
3039 GV *filter_child_proc = 0;
3040 SV *filter_state = 0;
3045 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3046 UV rev = 0, ver = 0, sver = 0;
3048 U8 *s = (U8*)SvPVX(sv);
3049 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3051 rev = utf8_to_uv(s, end - s, &len, 0);
3054 ver = utf8_to_uv(s, end - s, &len, 0);
3057 sver = utf8_to_uv(s, end - s, &len, 0);
3060 if (PERL_REVISION < rev
3061 || (PERL_REVISION == rev
3062 && (PERL_VERSION < ver
3063 || (PERL_VERSION == ver
3064 && PERL_SUBVERSION < sver))))
3066 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3067 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3068 PERL_VERSION, PERL_SUBVERSION);
3072 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3073 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3074 + ((NV)PERL_SUBVERSION/(NV)1000000)
3075 + 0.00000099 < SvNV(sv))
3079 NV nver = (nrev - rev) * 1000;
3080 UV ver = (UV)(nver + 0.0009);
3081 NV nsver = (nver - ver) * 1000;
3082 UV sver = (UV)(nsver + 0.0009);
3084 /* help out with the "use 5.6" confusion */
3085 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3086 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3087 "this is only v%d.%d.%d, stopped"
3088 " (did you mean v%"UVuf".%"UVuf".0?)",
3089 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3090 PERL_SUBVERSION, rev, ver/100);
3093 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3094 "this is only v%d.%d.%d, stopped",
3095 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3102 name = SvPV(sv, len);
3103 if (!(name && len > 0 && *name))
3104 DIE(aTHX_ "Null filename used");
3105 TAINT_PROPER("require");
3106 if (PL_op->op_type == OP_REQUIRE &&
3107 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3108 *svp != &PL_sv_undef)
3111 /* prepare to compile file */
3113 if (PERL_FILE_IS_ABSOLUTE(name)
3114 || (*name == '.' && (name[1] == '/' ||
3115 (name[1] == '.' && name[2] == '/'))))
3118 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3119 #ifdef MACOS_TRADITIONAL
3120 /* We consider paths of the form :a:b ambiguous and interpret them first
3121 as global then as local
3123 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3132 AV *ar = GvAVn(PL_incgv);
3136 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3139 namesv = NEWSV(806, 0);
3140 for (i = 0; i <= AvFILL(ar); i++) {
3141 SV *dirsv = *av_fetch(ar, i, TRUE);
3147 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3148 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3151 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3152 PTR2UV(SvANY(loader)), name);
3153 tryname = SvPVX(namesv);
3164 count = call_sv(loader, G_ARRAY);
3174 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3178 if (SvTYPE(arg) == SVt_PVGV) {
3179 IO *io = GvIO((GV *)arg);
3184 tryrsfp = IoIFP(io);
3185 if (IoTYPE(io) == IoTYPE_PIPE) {
3186 /* reading from a child process doesn't
3187 nest -- when returning from reading
3188 the inner module, the outer one is
3189 unreadable (closed?) I've tried to
3190 save the gv to manage the lifespan of
3191 the pipe, but this didn't help. XXX */
3192 filter_child_proc = (GV *)arg;
3193 (void)SvREFCNT_inc(filter_child_proc);
3196 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3197 PerlIO_close(IoOFP(io));
3209 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3211 (void)SvREFCNT_inc(filter_sub);
3214 filter_state = SP[i];
3215 (void)SvREFCNT_inc(filter_state);
3219 tryrsfp = PerlIO_open("/dev/null",
3233 filter_has_file = 0;
3234 if (filter_child_proc) {
3235 SvREFCNT_dec(filter_child_proc);
3236 filter_child_proc = 0;
3239 SvREFCNT_dec(filter_state);
3243 SvREFCNT_dec(filter_sub);
3248 char *dir = SvPVx(dirsv, n_a);
3249 #ifdef MACOS_TRADITIONAL
3251 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3255 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3257 sv_setpv(namesv, unixdir);
3258 sv_catpv(namesv, unixname);
3260 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3263 TAINT_PROPER("require");
3264 tryname = SvPVX(namesv);
3265 #ifdef MACOS_TRADITIONAL
3267 /* Convert slashes in the name part, but not the directory part, to colons */
3269 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3273 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3275 if (tryname[0] == '.' && tryname[1] == '/')
3283 SAVECOPFILE_FREE(&PL_compiling);
3284 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3285 SvREFCNT_dec(namesv);
3287 if (PL_op->op_type == OP_REQUIRE) {
3288 char *msgstr = name;
3289 if (namesv) { /* did we lookup @INC? */
3290 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3291 SV *dirmsgsv = NEWSV(0, 0);
3292 AV *ar = GvAVn(PL_incgv);
3294 sv_catpvn(msg, " in @INC", 8);
3295 if (instr(SvPVX(msg), ".h "))
3296 sv_catpv(msg, " (change .h to .ph maybe?)");
3297 if (instr(SvPVX(msg), ".ph "))
3298 sv_catpv(msg, " (did you run h2ph?)");
3299 sv_catpv(msg, " (@INC contains:");
3300 for (i = 0; i <= AvFILL(ar); i++) {
3301 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3302 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3303 sv_catsv(msg, dirmsgsv);
3305 sv_catpvn(msg, ")", 1);
3306 SvREFCNT_dec(dirmsgsv);
3307 msgstr = SvPV_nolen(msg);
3309 DIE(aTHX_ "Can't locate %s", msgstr);
3315 SETERRNO(0, SS$_NORMAL);
3317 /* Assume success here to prevent recursive requirement. */
3318 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3319 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3323 lex_start(sv_2mortal(newSVpvn("",0)));
3324 SAVEGENERICSV(PL_rsfp_filters);
3325 PL_rsfp_filters = Nullav;
3330 SAVESPTR(PL_compiling.cop_warnings);
3331 if (PL_dowarn & G_WARN_ALL_ON)
3332 PL_compiling.cop_warnings = pWARN_ALL ;
3333 else if (PL_dowarn & G_WARN_ALL_OFF)
3334 PL_compiling.cop_warnings = pWARN_NONE ;
3336 PL_compiling.cop_warnings = pWARN_STD ;
3337 SAVESPTR(PL_compiling.cop_io);
3338 PL_compiling.cop_io = Nullsv;
3340 if (filter_sub || filter_child_proc) {
3341 SV *datasv = filter_add(run_user_filter, Nullsv);
3342 IoLINES(datasv) = filter_has_file;
3343 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3344 IoTOP_GV(datasv) = (GV *)filter_state;
3345 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3348 /* switch to eval mode */
3349 push_return(PL_op->op_next);
3350 PUSHBLOCK(cx, CXt_EVAL, SP);
3351 PUSHEVAL(cx, name, Nullgv);
3353 SAVECOPLINE(&PL_compiling);
3354 CopLINE_set(&PL_compiling, 0);
3358 MUTEX_LOCK(&PL_eval_mutex);
3359 if (PL_eval_owner && PL_eval_owner != thr)
3360 while (PL_eval_owner)
3361 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3362 PL_eval_owner = thr;
3363 MUTEX_UNLOCK(&PL_eval_mutex);
3364 #endif /* USE_THREADS */
3365 return DOCATCH(doeval(G_SCALAR, NULL));
3370 return pp_require();
3376 register PERL_CONTEXT *cx;
3378 I32 gimme = GIMME_V, was = PL_sub_generation;
3379 char tbuf[TYPE_DIGITS(long) + 12];
3380 char *tmpbuf = tbuf;
3385 if (!SvPV(sv,len) || !len)
3387 TAINT_PROPER("eval");
3393 /* switch to eval mode */
3395 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3396 SV *sv = sv_newmortal();
3397 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3398 (unsigned long)++PL_evalseq,
3399 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3403 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3404 SAVECOPFILE_FREE(&PL_compiling);
3405 CopFILE_set(&PL_compiling, tmpbuf+2);
3406 SAVECOPLINE(&PL_compiling);
3407 CopLINE_set(&PL_compiling, 1);
3408 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3409 deleting the eval's FILEGV from the stash before gv_check() runs
3410 (i.e. before run-time proper). To work around the coredump that
3411 ensues, we always turn GvMULTI_on for any globals that were
3412 introduced within evals. See force_ident(). GSAR 96-10-12 */
3413 safestr = savepv(tmpbuf);
3414 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3416 PL_hints = PL_op->op_targ;
3417 SAVESPTR(PL_compiling.cop_warnings);
3418 if (specialWARN(PL_curcop->cop_warnings))
3419 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3421 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3422 SAVEFREESV(PL_compiling.cop_warnings);
3424 SAVESPTR(PL_compiling.cop_io);
3425 if (specialCopIO(PL_curcop->cop_io))
3426 PL_compiling.cop_io = PL_curcop->cop_io;
3428 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3429 SAVEFREESV(PL_compiling.cop_io);
3432 push_return(PL_op->op_next);
3433 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3434 PUSHEVAL(cx, 0, Nullgv);
3436 /* prepare to compile string */
3438 if (PERLDB_LINE && PL_curstash != PL_debstash)
3439 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3442 MUTEX_LOCK(&PL_eval_mutex);
3443 if (PL_eval_owner && PL_eval_owner != thr)
3444 while (PL_eval_owner)
3445 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3446 PL_eval_owner = thr;
3447 MUTEX_UNLOCK(&PL_eval_mutex);
3448 #endif /* USE_THREADS */
3449 ret = doeval(gimme, NULL);
3450 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3451 && ret != PL_op->op_next) { /* Successive compilation. */
3452 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3454 return DOCATCH(ret);
3464 register PERL_CONTEXT *cx;
3466 U8 save_flags = PL_op -> op_flags;
3471 retop = pop_return();
3474 if (gimme == G_VOID)
3476 else if (gimme == G_SCALAR) {
3479 if (SvFLAGS(TOPs) & SVs_TEMP)
3482 *MARK = sv_mortalcopy(TOPs);
3486 *MARK = &PL_sv_undef;
3491 /* in case LEAVE wipes old return values */
3492 for (mark = newsp + 1; mark <= SP; mark++) {
3493 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3494 *mark = sv_mortalcopy(*mark);
3495 TAINT_NOT; /* Each item is independent */
3499 PL_curpm = newpm; /* Don't pop $1 et al till now */
3501 if (AvFILLp(PL_comppad_name) >= 0)
3505 assert(CvDEPTH(PL_compcv) == 1);
3507 CvDEPTH(PL_compcv) = 0;
3510 if (optype == OP_REQUIRE &&
3511 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3513 /* Unassume the success we assumed earlier. */
3514 SV *nsv = cx->blk_eval.old_namesv;
3515 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3516 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3517 /* die_where() did LEAVE, or we won't be here */
3521 if (!(save_flags & OPf_SPECIAL))
3531 register PERL_CONTEXT *cx;
3532 I32 gimme = GIMME_V;
3537 push_return(cLOGOP->op_other->op_next);
3538 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3540 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3542 PL_in_eval = EVAL_INEVAL;
3545 return DOCATCH(PL_op->op_next);
3555 register PERL_CONTEXT *cx;
3563 if (gimme == G_VOID)
3565 else if (gimme == G_SCALAR) {
3568 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3571 *MARK = sv_mortalcopy(TOPs);
3575 *MARK = &PL_sv_undef;
3580 /* in case LEAVE wipes old return values */
3581 for (mark = newsp + 1; mark <= SP; mark++) {
3582 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3583 *mark = sv_mortalcopy(*mark);
3584 TAINT_NOT; /* Each item is independent */
3588 PL_curpm = newpm; /* Don't pop $1 et al till now */
3596 S_doparseform(pTHX_ SV *sv)
3599 register char *s = SvPV_force(sv, len);
3600 register char *send = s + len;
3601 register char *base;
3602 register I32 skipspaces = 0;
3605 bool postspace = FALSE;
3613 Perl_croak(aTHX_ "Null picture in formline");
3615 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3620 *fpc++ = FF_LINEMARK;
3621 noblank = repeat = FALSE;
3639 case ' ': case '\t':
3650 *fpc++ = FF_LITERAL;
3658 *fpc++ = skipspaces;
3662 *fpc++ = FF_NEWLINE;
3666 arg = fpc - linepc + 1;
3673 *fpc++ = FF_LINEMARK;
3674 noblank = repeat = FALSE;
3683 ischop = s[-1] == '^';
3689 arg = (s - base) - 1;
3691 *fpc++ = FF_LITERAL;
3700 *fpc++ = FF_LINEGLOB;
3702 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3703 arg = ischop ? 512 : 0;
3713 arg |= 256 + (s - f);
3715 *fpc++ = s - base; /* fieldsize for FETCH */
3716 *fpc++ = FF_DECIMAL;
3719 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3720 arg = ischop ? 512 : 0;
3722 s++; /* skip the '0' first */
3731 arg |= 256 + (s - f);
3733 *fpc++ = s - base; /* fieldsize for FETCH */
3734 *fpc++ = FF_0DECIMAL;
3739 bool ismore = FALSE;
3742 while (*++s == '>') ;
3743 prespace = FF_SPACE;
3745 else if (*s == '|') {
3746 while (*++s == '|') ;
3747 prespace = FF_HALFSPACE;
3752 while (*++s == '<') ;
3755 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3759 *fpc++ = s - base; /* fieldsize for FETCH */
3761 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3779 { /* need to jump to the next word */
3781 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3782 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3783 s = SvPVX(sv) + SvCUR(sv) + z;
3785 Copy(fops, s, arg, U16);
3787 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3792 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3794 * The original code was written in conjunction with BSD Computer Software
3795 * Research Group at University of California, Berkeley.
3797 * See also: "Optimistic Merge Sort" (SODA '92)
3799 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3801 * The code can be distributed under the same terms as Perl itself.
3806 #include <sys/types.h>
3811 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3812 #define Safefree(VAR) free(VAR)
3813 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3814 #endif /* TESTHARNESS */
3816 typedef char * aptr; /* pointer for arithmetic on sizes */
3817 typedef SV * gptr; /* pointers in our lists */
3819 /* Binary merge internal sort, with a few special mods
3820 ** for the special perl environment it now finds itself in.
3822 ** Things that were once options have been hotwired
3823 ** to values suitable for this use. In particular, we'll always
3824 ** initialize looking for natural runs, we'll always produce stable
3825 ** output, and we'll always do Peter McIlroy's binary merge.
3828 /* Pointer types for arithmetic and storage and convenience casts */
3830 #define APTR(P) ((aptr)(P))
3831 #define GPTP(P) ((gptr *)(P))
3832 #define GPPP(P) ((gptr **)(P))
3835 /* byte offset from pointer P to (larger) pointer Q */
3836 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3838 #define PSIZE sizeof(gptr)
3840 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3843 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3844 #define PNBYTE(N) ((N) << (PSHIFT))
3845 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3847 /* Leave optimization to compiler */
3848 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3849 #define PNBYTE(N) ((N) * (PSIZE))
3850 #define PINDEX(P, N) (GPTP(P) + (N))
3853 /* Pointer into other corresponding to pointer into this */
3854 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3856 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3859 /* Runs are identified by a pointer in the auxilliary list.
3860 ** The pointer is at the start of the list,
3861 ** and it points to the start of the next list.
3862 ** NEXT is used as an lvalue, too.
3865 #define NEXT(P) (*GPPP(P))
3868 /* PTHRESH is the minimum number of pairs with the same sense to justify
3869 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3870 ** not just elements, so PTHRESH == 8 means a run of 16.
3875 /* RTHRESH is the number of elements in a run that must compare low
3876 ** to the low element from the opposing run before we justify
3877 ** doing a binary rampup instead of single stepping.
3878 ** In random input, N in a row low should only happen with
3879 ** probability 2^(1-N), so we can risk that we are dealing
3880 ** with orderly input without paying much when we aren't.
3887 ** Overview of algorithm and variables.
3888 ** The array of elements at list1 will be organized into runs of length 2,
3889 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3890 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3892 ** Unless otherwise specified, pair pointers address the first of two elements.
3894 ** b and b+1 are a pair that compare with sense ``sense''.
3895 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3897 ** p2 parallels b in the list2 array, where runs are defined by
3900 ** t represents the ``top'' of the adjacent pairs that might extend
3901 ** the run beginning at b. Usually, t addresses a pair
3902 ** that compares with opposite sense from (b,b+1).
3903 ** However, it may also address a singleton element at the end of list1,
3904 ** or it may be equal to ``last'', the first element beyond list1.
3906 ** r addresses the Nth pair following b. If this would be beyond t,
3907 ** we back it off to t. Only when r is less than t do we consider the
3908 ** run long enough to consider checking.
3910 ** q addresses a pair such that the pairs at b through q already form a run.
3911 ** Often, q will equal b, indicating we only are sure of the pair itself.
3912 ** However, a search on the previous cycle may have revealed a longer run,
3913 ** so q may be greater than b.
3915 ** p is used to work back from a candidate r, trying to reach q,
3916 ** which would mean b through r would be a run. If we discover such a run,
3917 ** we start q at r and try to push it further towards t.
3918 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3919 ** In any event, after the check (if any), we have two main cases.
3921 ** 1) Short run. b <= q < p <= r <= t.
3922 ** b through q is a run (perhaps trivial)
3923 ** q through p are uninteresting pairs
3924 ** p through r is a run
3926 ** 2) Long run. b < r <= q < t.
3927 ** b through q is a run (of length >= 2 * PTHRESH)
3929 ** Note that degenerate cases are not only possible, but likely.
3930 ** For example, if the pair following b compares with opposite sense,
3931 ** then b == q < p == r == t.
3936 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3939 register gptr *b, *p, *q, *t, *p2;
3940 register gptr c, *last, *r;
3944 last = PINDEX(b, nmemb);
3945 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3946 for (p2 = list2; b < last; ) {
3947 /* We just started, or just reversed sense.
3948 ** Set t at end of pairs with the prevailing sense.
3950 for (p = b+2, t = p; ++p < last; t = ++p) {
3951 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3954 /* Having laid out the playing field, look for long runs */
3956 p = r = b + (2 * PTHRESH);
3957 if (r >= t) p = r = t; /* too short to care about */
3959 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3962 /* b through r is a (long) run.
3963 ** Extend it as far as possible.
3966 while (((p += 2) < t) &&
3967 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3968 r = p = q + 2; /* no simple pairs, no after-run */
3971 if (q > b) { /* run of greater than 2 at b */
3974 /* pick up singleton, if possible */
3976 ((t + 1) == last) &&
3977 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3978 savep = r = p = q = last;
3979 p2 = NEXT(p2) = p2 + (p - b);
3980 if (sense) while (b < --p) {
3987 while (q < p) { /* simple pairs */
3988 p2 = NEXT(p2) = p2 + 2;
3995 if (((b = p) == t) && ((t+1) == last)) {
4007 /* Overview of bmerge variables:
4009 ** list1 and list2 address the main and auxiliary arrays.
4010 ** They swap identities after each merge pass.
4011 ** Base points to the original list1, so we can tell if
4012 ** the pointers ended up where they belonged (or must be copied).
4014 ** When we are merging two lists, f1 and f2 are the next elements
4015 ** on the respective lists. l1 and l2 mark the end of the lists.
4016 ** tp2 is the current location in the merged list.
4018 ** p1 records where f1 started.
4019 ** After the merge, a new descriptor is built there.
4021 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4022 ** It is used to identify and delimit the runs.
4024 ** In the heat of determining where q, the greater of the f1/f2 elements,
4025 ** belongs in the other list, b, t and p, represent bottom, top and probe
4026 ** locations, respectively, in the other list.
4027 ** They make convenient temporary pointers in other places.
4031 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4035 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4036 gptr *aux, *list2, *p2, *last;
4040 if (nmemb <= 1) return; /* sorted trivially */
4041 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4043 dynprep(aTHX_ list1, list2, nmemb, cmp);
4044 last = PINDEX(list2, nmemb);
4045 while (NEXT(list2) != last) {
4046 /* More than one run remains. Do some merging to reduce runs. */
4048 for (tp2 = p2 = list2; p2 != last;) {
4049 /* The new first run begins where the old second list ended.
4050 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4054 f2 = l1 = POTHER(t, list2, list1);
4055 if (t != last) t = NEXT(t);
4056 l2 = POTHER(t, list2, list1);
4058 while (f1 < l1 && f2 < l2) {
4059 /* If head 1 is larger than head 2, find ALL the elements
4060 ** in list 2 strictly less than head1, write them all,
4061 ** then head 1. Then compare the new heads, and repeat,
4062 ** until one or both lists are exhausted.
4064 ** In all comparisons (after establishing
4065 ** which head to merge) the item to merge
4066 ** (at pointer q) is the first operand of
4067 ** the comparison. When we want to know
4068 ** if ``q is strictly less than the other'',
4070 ** cmp(q, other) < 0
4071 ** because stability demands that we treat equality
4072 ** as high when q comes from l2, and as low when
4073 ** q was from l1. So we ask the question by doing
4074 ** cmp(q, other) <= sense
4075 ** and make sense == 0 when equality should look low,
4076 ** and -1 when equality should look high.
4080 if (cmp(aTHX_ *f1, *f2) <= 0) {
4081 q = f2; b = f1; t = l1;
4084 q = f1; b = f2; t = l2;
4091 ** Leave t at something strictly
4092 ** greater than q (or at the end of the list),
4093 ** and b at something strictly less than q.
4095 for (i = 1, run = 0 ;;) {
4096 if ((p = PINDEX(b, i)) >= t) {
4098 if (((p = PINDEX(t, -1)) > b) &&
4099 (cmp(aTHX_ *q, *p) <= sense))
4103 } else if (cmp(aTHX_ *q, *p) <= sense) {
4107 if (++run >= RTHRESH) i += i;
4111 /* q is known to follow b and must be inserted before t.
4112 ** Increment b, so the range of possibilities is [b,t).
4113 ** Round binary split down, to favor early appearance.
4114 ** Adjust b and t until q belongs just before t.
4119 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4120 if (cmp(aTHX_ *q, *p) <= sense) {
4126 /* Copy all the strictly low elements */
4129 FROMTOUPTO(f2, tp2, t);
4132 FROMTOUPTO(f1, tp2, t);
4138 /* Run out remaining list */
4140 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4141 } else FROMTOUPTO(f1, tp2, l1);
4142 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4147 last = PINDEX(list2, nmemb);
4149 if (base == list2) {
4150 last = PINDEX(list1, nmemb);
4151 FROMTOUPTO(list1, list2, last);
4166 sortcv(pTHXo_ SV *a, SV *b)
4168 I32 oldsaveix = PL_savestack_ix;
4169 I32 oldscopeix = PL_scopestack_ix;
4171 GvSV(PL_firstgv) = a;
4172 GvSV(PL_secondgv) = b;
4173 PL_stack_sp = PL_stack_base;
4176 if (PL_stack_sp != PL_stack_base + 1)
4177 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4178 if (!SvNIOKp(*PL_stack_sp))
4179 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4180 result = SvIV(*PL_stack_sp);
4181 while (PL_scopestack_ix > oldscopeix) {
4184 leave_scope(oldsaveix);
4189 sortcv_stacked(pTHXo_ SV *a, SV *b)
4191 I32 oldsaveix = PL_savestack_ix;
4192 I32 oldscopeix = PL_scopestack_ix;
4197 av = (AV*)PL_curpad[0];
4199 av = GvAV(PL_defgv);
4202 if (AvMAX(av) < 1) {
4203 SV** ary = AvALLOC(av);
4204 if (AvARRAY(av) != ary) {
4205 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4206 SvPVX(av) = (char*)ary;
4208 if (AvMAX(av) < 1) {
4211 SvPVX(av) = (char*)ary;
4218 PL_stack_sp = PL_stack_base;
4221 if (PL_stack_sp != PL_stack_base + 1)
4222 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4223 if (!SvNIOKp(*PL_stack_sp))
4224 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4225 result = SvIV(*PL_stack_sp);
4226 while (PL_scopestack_ix > oldscopeix) {
4229 leave_scope(oldsaveix);
4234 sortcv_xsub(pTHXo_ SV *a, SV *b)
4237 I32 oldsaveix = PL_savestack_ix;
4238 I32 oldscopeix = PL_scopestack_ix;
4240 CV *cv=(CV*)PL_sortcop;
4248 (void)(*CvXSUB(cv))(aTHXo_ cv);
4249 if (PL_stack_sp != PL_stack_base + 1)
4250 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4251 if (!SvNIOKp(*PL_stack_sp))
4252 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4253 result = SvIV(*PL_stack_sp);
4254 while (PL_scopestack_ix > oldscopeix) {
4257 leave_scope(oldsaveix);
4263 sv_ncmp(pTHXo_ SV *a, SV *b)
4267 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4271 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4275 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4277 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4279 if (PL_amagic_generation) { \
4280 if (SvAMAGIC(left)||SvAMAGIC(right))\
4281 *svp = amagic_call(left, \
4289 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4292 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4297 I32 i = SvIVX(tmpsv);
4307 return sv_ncmp(aTHXo_ a, b);
4311 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4314 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4319 I32 i = SvIVX(tmpsv);
4329 return sv_i_ncmp(aTHXo_ a, b);
4333 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4336 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4341 I32 i = SvIVX(tmpsv);
4351 return sv_cmp(str1, str2);
4355 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4358 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4363 I32 i = SvIVX(tmpsv);
4373 return sv_cmp_locale(str1, str2);
4377 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4379 SV *datasv = FILTER_DATA(idx);
4380 int filter_has_file = IoLINES(datasv);
4381 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4382 SV *filter_state = (SV *)IoTOP_GV(datasv);
4383 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4386 /* I was having segfault trouble under Linux 2.2.5 after a
4387 parse error occured. (Had to hack around it with a test
4388 for PL_error_count == 0.) Solaris doesn't segfault --
4389 not sure where the trouble is yet. XXX */
4391 if (filter_has_file) {
4392 len = FILTER_READ(idx+1, buf_sv, maxlen);
4395 if (filter_sub && len >= 0) {
4406 PUSHs(sv_2mortal(newSViv(maxlen)));
4408 PUSHs(filter_state);
4411 count = call_sv(filter_sub, G_SCALAR);
4427 IoLINES(datasv) = 0;
4428 if (filter_child_proc) {
4429 SvREFCNT_dec(filter_child_proc);
4430 IoFMT_GV(datasv) = Nullgv;
4433 SvREFCNT_dec(filter_state);
4434 IoTOP_GV(datasv) = Nullgv;
4437 SvREFCNT_dec(filter_sub);
4438 IoBOTTOM_GV(datasv) = Nullgv;
4440 filter_del(run_user_filter);
4449 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4451 return sv_cmp_locale(str1, str2);
4455 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4457 return sv_cmp(str1, str2);
4460 #endif /* PERL_OBJECT */