3 * Copyright (c) 1991-2000, 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_UTF8;
119 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
120 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
121 inside tie/overload accessors. */
125 #ifndef INCOMPLETE_TAINTS
128 pm->op_pmdynflags |= PMdf_TAINTED;
130 pm->op_pmdynflags &= ~PMdf_TAINTED;
134 if (!pm->op_pmregexp->prelen && PL_curpm)
136 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
137 pm->op_pmflags |= PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
161 rxres_restore(&cx->sb_rxres, rx);
163 if (cx->sb_iters++) {
164 if (cx->sb_iters > cx->sb_maxiters)
165 DIE(aTHX_ "Substitution loop");
167 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
168 cx->sb_rxtainted |= 2;
169 sv_catsv(dstr, POPs);
172 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
173 s == m, cx->sb_targ, NULL,
174 ((cx->sb_rflags & REXEC_COPY_STR)
175 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
176 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
178 SV *targ = cx->sb_targ;
179 sv_catpvn(dstr, s, cx->sb_strend - s);
181 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183 (void)SvOOK_off(targ);
184 Safefree(SvPVX(targ));
185 SvPVX(targ) = SvPVX(dstr);
186 SvCUR_set(targ, SvCUR(dstr));
187 SvLEN_set(targ, SvLEN(dstr));
191 TAINT_IF(cx->sb_rxtainted & 1);
192 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
194 (void)SvPOK_only(targ);
195 TAINT_IF(cx->sb_rxtainted);
199 LEAVE_SCOPE(cx->sb_oldsave);
201 RETURNOP(pm->op_next);
204 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
207 cx->sb_orig = orig = rx->subbeg;
209 cx->sb_strend = s + (cx->sb_strend - m);
211 cx->sb_m = m = rx->startp[0] + orig;
212 sv_catpvn(dstr, s, m-s);
213 cx->sb_s = rx->endp[0] + orig;
214 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
215 rxres_save(&cx->sb_rxres, rx);
216 RETURNOP(pm->op_pmreplstart);
220 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
225 if (!p || p[1] < rx->nparens) {
226 i = 6 + rx->nparens * 2;
234 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
235 RX_MATCH_COPIED_off(rx);
239 *p++ = PTR2UV(rx->subbeg);
240 *p++ = (UV)rx->sublen;
241 for (i = 0; i <= rx->nparens; ++i) {
242 *p++ = (UV)rx->startp[i];
243 *p++ = (UV)rx->endp[i];
248 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
253 if (RX_MATCH_COPIED(rx))
254 Safefree(rx->subbeg);
255 RX_MATCH_COPIED_set(rx, *p);
260 rx->subbeg = INT2PTR(char*,*p++);
261 rx->sublen = (I32)(*p++);
262 for (i = 0; i <= rx->nparens; ++i) {
263 rx->startp[i] = (I32)(*p++);
264 rx->endp[i] = (I32)(*p++);
269 Perl_rxres_free(pTHX_ void **rsp)
274 Safefree(INT2PTR(char*,*p));
282 djSP; dMARK; dORIGMARK;
283 register SV *tmpForm = *++MARK;
295 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
301 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
302 bool item_is_utf = FALSE;
304 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
305 if (SvREADONLY(tmpForm)) {
306 SvREADONLY_off(tmpForm);
307 doparseform(tmpForm);
308 SvREADONLY_on(tmpForm);
311 doparseform(tmpForm);
314 SvPV_force(PL_formtarget, len);
315 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
317 f = SvPV(tmpForm, len);
318 /* need to jump to the next word */
319 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
328 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
329 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
330 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
331 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
332 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
334 case FF_CHECKNL: name = "CHECKNL"; break;
335 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
336 case FF_SPACE: name = "SPACE"; break;
337 case FF_HALFSPACE: name = "HALFSPACE"; break;
338 case FF_ITEM: name = "ITEM"; break;
339 case FF_CHOP: name = "CHOP"; break;
340 case FF_LINEGLOB: name = "LINEGLOB"; break;
341 case FF_NEWLINE: name = "NEWLINE"; break;
342 case FF_MORE: name = "MORE"; break;
343 case FF_LINEMARK: name = "LINEMARK"; break;
344 case FF_END: name = "END"; break;
347 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
349 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
377 if (ckWARN(WARN_SYNTAX))
378 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
383 item = s = SvPV(sv, len);
386 itemsize = sv_len_utf8(sv);
387 if (itemsize != len) {
389 if (itemsize > fieldsize) {
390 itemsize = fieldsize;
391 itembytes = itemsize;
392 sv_pos_u2b(sv, &itembytes, 0);
396 send = chophere = s + itembytes;
406 sv_pos_b2u(sv, &itemsize);
411 if (itemsize > fieldsize)
412 itemsize = fieldsize;
413 send = chophere = s + itemsize;
425 item = s = SvPV(sv, len);
428 itemsize = sv_len_utf8(sv);
429 if (itemsize != len) {
431 if (itemsize <= fieldsize) {
432 send = chophere = s + itemsize;
443 itemsize = fieldsize;
444 itembytes = itemsize;
445 sv_pos_u2b(sv, &itembytes, 0);
446 send = chophere = s + itembytes;
447 while (s < send || (s == send && isSPACE(*s))) {
457 if (strchr(PL_chopset, *s))
462 itemsize = chophere - item;
463 sv_pos_b2u(sv, &itemsize);
470 if (itemsize <= fieldsize) {
471 send = chophere = s + itemsize;
482 itemsize = fieldsize;
483 send = chophere = s + itemsize;
484 while (s < send || (s == send && isSPACE(*s))) {
494 if (strchr(PL_chopset, *s))
499 itemsize = chophere - item;
504 arg = fieldsize - itemsize;
513 arg = fieldsize - itemsize;
528 switch (UTF8SKIP(s)) {
539 if ( !((*t++ = *s++) & ~31) )
547 int ch = *t++ = *s++;
550 if ( !((*t++ = *s++) & ~31) )
559 while (*s && isSPACE(*s))
566 item = s = SvPV(sv, len);
568 item_is_utf = FALSE; /* XXX is this correct? */
580 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
581 sv_catpvn(PL_formtarget, item, itemsize);
582 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
583 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
588 /* If the field is marked with ^ and the value is undefined,
591 if ((arg & 512) && !SvOK(sv)) {
599 /* Formats aren't yet marked for locales, so assume "yes". */
601 STORE_NUMERIC_STANDARD_SET_LOCAL();
602 #if defined(USE_LONG_DOUBLE)
604 sprintf(t, "%#*.*" PERL_PRIfldbl,
605 (int) fieldsize, (int) arg & 255, value);
607 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
612 (int) fieldsize, (int) arg & 255, value);
615 (int) fieldsize, value);
618 RESTORE_NUMERIC_STANDARD();
625 while (t-- > linemark && *t == ' ') ;
633 if (arg) { /* repeat until fields exhausted? */
635 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
636 lines += FmLINES(PL_formtarget);
639 if (strnEQ(linemark, linemark - arg, arg))
640 DIE(aTHX_ "Runaway format");
642 FmLINES(PL_formtarget) = lines;
644 RETURNOP(cLISTOP->op_first);
657 while (*s && isSPACE(*s) && s < send)
661 arg = fieldsize - itemsize;
668 if (strnEQ(s," ",3)) {
669 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
680 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
681 FmLINES(PL_formtarget) += lines;
693 if (PL_stack_base + *PL_markstack_ptr == SP) {
695 if (GIMME_V == G_SCALAR)
696 XPUSHs(sv_2mortal(newSViv(0)));
697 RETURNOP(PL_op->op_next->op_next);
699 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
700 pp_pushmark(); /* push dst */
701 pp_pushmark(); /* push src */
702 ENTER; /* enter outer scope */
705 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
707 ENTER; /* enter inner scope */
710 src = PL_stack_base[*PL_markstack_ptr];
715 if (PL_op->op_type == OP_MAPSTART)
716 pp_pushmark(); /* push top */
717 return ((LOGOP*)PL_op->op_next)->op_other;
722 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
728 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
734 /* first, move source pointer to the next item in the source list */
735 ++PL_markstack_ptr[-1];
737 /* if there are new items, push them into the destination list */
739 /* might need to make room back there first */
740 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
741 /* XXX this implementation is very pessimal because the stack
742 * is repeatedly extended for every set of items. Is possible
743 * to do this without any stack extension or copying at all
744 * by maintaining a separate list over which the map iterates
745 * (like foreach does). --gsar */
747 /* everything in the stack after the destination list moves
748 * towards the end the stack by the amount of room needed */
749 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
751 /* items to shift up (accounting for the moved source pointer) */
752 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
754 /* This optimization is by Ben Tilly and it does
755 * things differently from what Sarathy (gsar)
756 * is describing. The downside of this optimization is
757 * that leaves "holes" (uninitialized and hopefully unused areas)
758 * to the Perl stack, but on the other hand this
759 * shouldn't be a problem. If Sarathy's idea gets
760 * implemented, this optimization should become
761 * irrelevant. --jhi */
763 shift = count; /* Avoid shifting too often --Ben Tilly */
768 PL_markstack_ptr[-1] += shift;
769 *PL_markstack_ptr += shift;
773 /* copy the new items down to the destination list */
774 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
776 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
778 LEAVE; /* exit inner scope */
781 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
784 (void)POPMARK; /* pop top */
785 LEAVE; /* exit outer scope */
786 (void)POPMARK; /* pop src */
787 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
788 (void)POPMARK; /* pop dst */
789 SP = PL_stack_base + POPMARK; /* pop original mark */
790 if (gimme == G_SCALAR) {
794 else if (gimme == G_ARRAY)
801 ENTER; /* enter inner scope */
804 /* set $_ to the new source item */
805 src = PL_stack_base[PL_markstack_ptr[-1]];
809 RETURNOP(cLOGOP->op_other);
815 djSP; dMARK; dORIGMARK;
817 SV **myorigmark = ORIGMARK;
823 OP* nextop = PL_op->op_next;
825 bool hasargs = FALSE;
828 if (gimme != G_ARRAY) {
834 SAVEVPTR(PL_sortcop);
835 if (PL_op->op_flags & OPf_STACKED) {
836 if (PL_op->op_flags & OPf_SPECIAL) {
837 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
838 kid = kUNOP->op_first; /* pass rv2gv */
839 kid = kUNOP->op_first; /* pass leave */
840 PL_sortcop = kid->op_next;
841 stash = CopSTASH(PL_curcop);
844 cv = sv_2cv(*++MARK, &stash, &gv, 0);
845 if (cv && SvPOK(cv)) {
847 char *proto = SvPV((SV*)cv, n_a);
848 if (proto && strEQ(proto, "$$")) {
852 if (!(cv && CvROOT(cv))) {
853 if (cv && CvXSUB(cv)) {
857 SV *tmpstr = sv_newmortal();
858 gv_efullname3(tmpstr, gv, Nullch);
859 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
863 DIE(aTHX_ "Undefined subroutine in sort");
868 PL_sortcop = (OP*)cv;
870 PL_sortcop = CvSTART(cv);
871 SAVEVPTR(CvROOT(cv)->op_ppaddr);
872 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
875 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
881 stash = CopSTASH(PL_curcop);
885 while (MARK < SP) { /* This may or may not shift down one here. */
887 if ((*up = *++MARK)) { /* Weed out nulls. */
889 if (!PL_sortcop && !SvPOK(*up)) {
894 (void)sv_2pv(*up, &n_a);
899 max = --up - myorigmark;
904 bool oldcatch = CATCH_GET;
910 PUSHSTACKi(PERLSI_SORT);
911 if (!hasargs && !is_xsub) {
912 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
913 SAVESPTR(PL_firstgv);
914 SAVESPTR(PL_secondgv);
915 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
916 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
917 PL_sortstash = stash;
920 sv_lock((SV *)PL_firstgv);
921 sv_lock((SV *)PL_secondgv);
923 SAVESPTR(GvSV(PL_firstgv));
924 SAVESPTR(GvSV(PL_secondgv));
927 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
928 if (!(PL_op->op_flags & OPf_SPECIAL)) {
929 cx->cx_type = CXt_SUB;
930 cx->blk_gimme = G_SCALAR;
933 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
935 PL_sortcxix = cxstack_ix;
937 if (hasargs && !is_xsub) {
938 /* This is mostly copied from pp_entersub */
939 AV *av = (AV*)PL_curpad[0];
942 cx->blk_sub.savearray = GvAV(PL_defgv);
943 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
944 #endif /* USE_THREADS */
945 cx->blk_sub.oldcurpad = PL_curpad;
946 cx->blk_sub.argarray = av;
948 qsortsv((myorigmark+1), max,
949 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
951 POPBLOCK(cx,PL_curpm);
959 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
960 qsortsv(ORIGMARK+1, max,
961 (PL_op->op_private & OPpSORT_NUMERIC)
962 ? ( (PL_op->op_private & OPpSORT_INTEGER)
963 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
964 : ( overloading ? amagic_ncmp : sv_ncmp))
965 : ( (PL_op->op_private & OPpLOCALE)
968 : sv_cmp_locale_static)
969 : ( overloading ? amagic_cmp : sv_cmp_static)));
970 if (PL_op->op_private & OPpSORT_REVERSE) {
972 SV **q = ORIGMARK+max;
982 PL_stack_sp = ORIGMARK + max;
990 if (GIMME == G_ARRAY)
992 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
993 return cLOGOP->op_other;
1002 if (GIMME == G_ARRAY) {
1003 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1007 SV *targ = PAD_SV(PL_op->op_targ);
1010 if (PL_op->op_private & OPpFLIP_LINENUM) {
1012 flip = PL_last_in_gv
1013 && (gp_io = GvIOp(PL_last_in_gv))
1014 && SvIV(sv) == (IV)IoLINES(gp_io);
1019 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1020 if (PL_op->op_flags & OPf_SPECIAL) {
1028 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1041 if (GIMME == G_ARRAY) {
1047 if (SvGMAGICAL(left))
1049 if (SvGMAGICAL(right))
1052 if (SvNIOKp(left) || !SvPOKp(left) ||
1053 SvNIOKp(right) || !SvPOKp(right) ||
1054 (looks_like_number(left) && *SvPVX(left) != '0' &&
1055 looks_like_number(right) && *SvPVX(right) != '0'))
1057 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1058 DIE(aTHX_ "Range iterator outside integer range");
1069 sv = sv_2mortal(newSViv(i++));
1074 SV *final = sv_mortalcopy(right);
1076 char *tmps = SvPV(final, len);
1078 sv = sv_mortalcopy(left);
1080 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1082 if (strEQ(SvPVX(sv),tmps))
1084 sv = sv_2mortal(newSVsv(sv));
1091 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1093 if ((PL_op->op_private & OPpFLIP_LINENUM)
1094 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1096 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1097 sv_catpv(targ, "E0");
1108 S_dopoptolabel(pTHX_ char *label)
1112 register PERL_CONTEXT *cx;
1114 for (i = cxstack_ix; i >= 0; i--) {
1116 switch (CxTYPE(cx)) {
1118 if (ckWARN(WARN_EXITING))
1119 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1120 PL_op_name[PL_op->op_type]);
1123 if (ckWARN(WARN_EXITING))
1124 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1125 PL_op_name[PL_op->op_type]);
1128 if (ckWARN(WARN_EXITING))
1129 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1130 PL_op_name[PL_op->op_type]);
1133 if (ckWARN(WARN_EXITING))
1134 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1135 PL_op_name[PL_op->op_type]);
1138 if (ckWARN(WARN_EXITING))
1139 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1140 PL_op_name[PL_op->op_type]);
1143 if (!cx->blk_loop.label ||
1144 strNE(label, cx->blk_loop.label) ) {
1145 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1146 (long)i, cx->blk_loop.label));
1149 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1157 Perl_dowantarray(pTHX)
1159 I32 gimme = block_gimme();
1160 return (gimme == G_VOID) ? G_SCALAR : gimme;
1164 Perl_block_gimme(pTHX)
1169 cxix = dopoptosub(cxstack_ix);
1173 switch (cxstack[cxix].blk_gimme) {
1181 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1188 S_dopoptosub(pTHX_ I32 startingblock)
1191 return dopoptosub_at(cxstack, startingblock);
1195 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1199 register PERL_CONTEXT *cx;
1200 for (i = startingblock; i >= 0; i--) {
1202 switch (CxTYPE(cx)) {
1208 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1216 S_dopoptoeval(pTHX_ I32 startingblock)
1220 register PERL_CONTEXT *cx;
1221 for (i = startingblock; i >= 0; i--) {
1223 switch (CxTYPE(cx)) {
1227 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1235 S_dopoptoloop(pTHX_ I32 startingblock)
1239 register PERL_CONTEXT *cx;
1240 for (i = startingblock; i >= 0; i--) {
1242 switch (CxTYPE(cx)) {
1244 if (ckWARN(WARN_EXITING))
1245 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1246 PL_op_name[PL_op->op_type]);
1249 if (ckWARN(WARN_EXITING))
1250 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1251 PL_op_name[PL_op->op_type]);
1254 if (ckWARN(WARN_EXITING))
1255 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1256 PL_op_name[PL_op->op_type]);
1259 if (ckWARN(WARN_EXITING))
1260 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1261 PL_op_name[PL_op->op_type]);
1264 if (ckWARN(WARN_EXITING))
1265 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1266 PL_op_name[PL_op->op_type]);
1269 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1277 Perl_dounwind(pTHX_ I32 cxix)
1280 register PERL_CONTEXT *cx;
1283 while (cxstack_ix > cxix) {
1285 cx = &cxstack[cxstack_ix];
1286 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1287 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1288 /* Note: we don't need to restore the base context info till the end. */
1289 switch (CxTYPE(cx)) {
1292 continue; /* not break */
1314 * Closures mentioned at top level of eval cannot be referenced
1315 * again, and their presence indirectly causes a memory leak.
1316 * (Note that the fact that compcv and friends are still set here
1317 * is, AFAIK, an accident.) --Chip
1319 * XXX need to get comppad et al from eval's cv rather than
1320 * relying on the incidental global values.
1323 S_free_closures(pTHX)
1326 SV **svp = AvARRAY(PL_comppad_name);
1328 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1330 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1332 svp[ix] = &PL_sv_undef;
1336 SvREFCNT_dec(CvOUTSIDE(sv));
1337 CvOUTSIDE(sv) = Nullcv;
1350 Perl_qerror(pTHX_ SV *err)
1353 sv_catsv(ERRSV, err);
1355 sv_catsv(PL_errors, err);
1357 Perl_warn(aTHX_ "%"SVf, err);
1362 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1367 register PERL_CONTEXT *cx;
1372 if (PL_in_eval & EVAL_KEEPERR) {
1373 static char prefix[] = "\t(in cleanup) ";
1378 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1381 if (*e != *message || strNE(e,message))
1385 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1386 sv_catpvn(err, prefix, sizeof(prefix)-1);
1387 sv_catpvn(err, message, msglen);
1388 if (ckWARN(WARN_MISC)) {
1389 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1390 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1395 sv_setpvn(ERRSV, message, msglen);
1398 message = SvPVx(ERRSV, msglen);
1400 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1401 && PL_curstackinfo->si_prev)
1410 if (cxix < cxstack_ix)
1413 POPBLOCK(cx,PL_curpm);
1414 if (CxTYPE(cx) != CXt_EVAL) {
1415 PerlIO_write(Perl_error_log, "panic: die ", 11);
1416 PerlIO_write(Perl_error_log, message, msglen);
1421 if (gimme == G_SCALAR)
1422 *++newsp = &PL_sv_undef;
1423 PL_stack_sp = newsp;
1427 /* LEAVE could clobber PL_curcop (see save_re_context())
1428 * XXX it might be better to find a way to avoid messing with
1429 * PL_curcop in save_re_context() instead, but this is a more
1430 * minimal fix --GSAR */
1431 PL_curcop = cx->blk_oldcop;
1433 if (optype == OP_REQUIRE) {
1434 char* msg = SvPVx(ERRSV, n_a);
1435 DIE(aTHX_ "%sCompilation failed in require",
1436 *msg ? msg : "Unknown error\n");
1438 return pop_return();
1442 message = SvPVx(ERRSV, msglen);
1445 /* SFIO can really mess with your errno */
1448 PerlIO *serr = Perl_error_log;
1450 PerlIO_write(serr, message, msglen);
1451 (void)PerlIO_flush(serr);
1464 if (SvTRUE(left) != SvTRUE(right))
1476 RETURNOP(cLOGOP->op_other);
1485 RETURNOP(cLOGOP->op_other);
1491 register I32 cxix = dopoptosub(cxstack_ix);
1492 register PERL_CONTEXT *cx;
1493 register PERL_CONTEXT *ccstack = cxstack;
1494 PERL_SI *top_si = PL_curstackinfo;
1505 /* we may be in a higher stacklevel, so dig down deeper */
1506 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1507 top_si = top_si->si_prev;
1508 ccstack = top_si->si_cxstack;
1509 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1512 if (GIMME != G_ARRAY)
1516 if (PL_DBsub && cxix >= 0 &&
1517 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1521 cxix = dopoptosub_at(ccstack, cxix - 1);
1524 cx = &ccstack[cxix];
1525 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1526 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1527 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1528 field below is defined for any cx. */
1529 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1530 cx = &ccstack[dbcxix];
1533 stashname = CopSTASHPV(cx->blk_oldcop);
1534 if (GIMME != G_ARRAY) {
1536 PUSHs(&PL_sv_undef);
1539 sv_setpv(TARG, stashname);
1546 PUSHs(&PL_sv_undef);
1548 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1549 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1550 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1553 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1554 /* So is ccstack[dbcxix]. */
1556 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1557 PUSHs(sv_2mortal(sv));
1558 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1561 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1562 PUSHs(sv_2mortal(newSViv(0)));
1564 gimme = (I32)cx->blk_gimme;
1565 if (gimme == G_VOID)
1566 PUSHs(&PL_sv_undef);
1568 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1569 if (CxTYPE(cx) == CXt_EVAL) {
1571 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1572 PUSHs(cx->blk_eval.cur_text);
1576 else if (cx->blk_eval.old_namesv) {
1577 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1580 /* eval BLOCK (try blocks have old_namesv == 0) */
1582 PUSHs(&PL_sv_undef);
1583 PUSHs(&PL_sv_undef);
1587 PUSHs(&PL_sv_undef);
1588 PUSHs(&PL_sv_undef);
1590 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1591 && CopSTASH_eq(PL_curcop, PL_debstash))
1593 AV *ary = cx->blk_sub.argarray;
1594 int off = AvARRAY(ary) - AvALLOC(ary);
1598 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1601 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1604 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1605 av_extend(PL_dbargs, AvFILLp(ary) + off);
1606 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1607 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1609 /* XXX only hints propagated via op_private are currently
1610 * visible (others are not easily accessible, since they
1611 * use the global PL_hints) */
1612 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1613 HINT_PRIVATE_MASK)));
1616 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1618 if (old_warnings == pWARN_NONE ||
1619 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1620 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1621 else if (old_warnings == pWARN_ALL ||
1622 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1623 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1625 mask = newSVsv(old_warnings);
1626 PUSHs(sv_2mortal(mask));
1641 sv_reset(tmps, CopSTASH(PL_curcop));
1653 PL_curcop = (COP*)PL_op;
1654 TAINT_NOT; /* Each statement is presumed innocent */
1655 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1658 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1662 register PERL_CONTEXT *cx;
1663 I32 gimme = G_ARRAY;
1670 DIE(aTHX_ "No DB::DB routine defined");
1672 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1684 push_return(PL_op->op_next);
1685 PUSHBLOCK(cx, CXt_SUB, SP);
1688 (void)SvREFCNT_inc(cv);
1689 SAVEVPTR(PL_curpad);
1690 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1691 RETURNOP(CvSTART(cv));
1705 register PERL_CONTEXT *cx;
1706 I32 gimme = GIMME_V;
1708 U32 cxtype = CXt_LOOP;
1717 if (PL_op->op_flags & OPf_SPECIAL) {
1719 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1720 SAVEGENERICSV(*svp);
1724 #endif /* USE_THREADS */
1725 if (PL_op->op_targ) {
1726 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1729 iterdata = (void*)PL_op->op_targ;
1730 cxtype |= CXp_PADVAR;
1735 svp = &GvSV(gv); /* symbol table variable */
1736 SAVEGENERICSV(*svp);
1739 iterdata = (void*)gv;
1745 PUSHBLOCK(cx, cxtype, SP);
1747 PUSHLOOP(cx, iterdata, MARK);
1749 PUSHLOOP(cx, svp, MARK);
1751 if (PL_op->op_flags & OPf_STACKED) {
1752 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1753 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1755 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1756 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1757 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1758 looks_like_number((SV*)cx->blk_loop.iterary) &&
1759 *SvPVX(cx->blk_loop.iterary) != '0'))
1761 if (SvNV(sv) < IV_MIN ||
1762 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1763 DIE(aTHX_ "Range iterator outside integer range");
1764 cx->blk_loop.iterix = SvIV(sv);
1765 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1768 cx->blk_loop.iterlval = newSVsv(sv);
1772 cx->blk_loop.iterary = PL_curstack;
1773 AvFILLp(PL_curstack) = SP - PL_stack_base;
1774 cx->blk_loop.iterix = MARK - PL_stack_base;
1783 register PERL_CONTEXT *cx;
1784 I32 gimme = GIMME_V;
1790 PUSHBLOCK(cx, CXt_LOOP, SP);
1791 PUSHLOOP(cx, 0, SP);
1799 register PERL_CONTEXT *cx;
1807 newsp = PL_stack_base + cx->blk_loop.resetsp;
1810 if (gimme == G_VOID)
1812 else if (gimme == G_SCALAR) {
1814 *++newsp = sv_mortalcopy(*SP);
1816 *++newsp = &PL_sv_undef;
1820 *++newsp = sv_mortalcopy(*++mark);
1821 TAINT_NOT; /* Each item is independent */
1827 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1828 PL_curpm = newpm; /* ... and pop $1 et al */
1840 register PERL_CONTEXT *cx;
1841 bool popsub2 = FALSE;
1842 bool clear_errsv = FALSE;
1849 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1850 if (cxstack_ix == PL_sortcxix
1851 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1853 if (cxstack_ix > PL_sortcxix)
1854 dounwind(PL_sortcxix);
1855 AvARRAY(PL_curstack)[1] = *SP;
1856 PL_stack_sp = PL_stack_base + 1;
1861 cxix = dopoptosub(cxstack_ix);
1863 DIE(aTHX_ "Can't return outside a subroutine");
1864 if (cxix < cxstack_ix)
1868 switch (CxTYPE(cx)) {
1873 if (!(PL_in_eval & EVAL_KEEPERR))
1878 if (AvFILLp(PL_comppad_name) >= 0)
1881 if (optype == OP_REQUIRE &&
1882 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1884 /* Unassume the success we assumed earlier. */
1885 SV *nsv = cx->blk_eval.old_namesv;
1886 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1887 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1894 DIE(aTHX_ "panic: return");
1898 if (gimme == G_SCALAR) {
1901 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1903 *++newsp = SvREFCNT_inc(*SP);
1908 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1910 *++newsp = sv_mortalcopy(sv);
1915 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1918 *++newsp = sv_mortalcopy(*SP);
1921 *++newsp = &PL_sv_undef;
1923 else if (gimme == G_ARRAY) {
1924 while (++MARK <= SP) {
1925 *++newsp = (popsub2 && SvTEMP(*MARK))
1926 ? *MARK : sv_mortalcopy(*MARK);
1927 TAINT_NOT; /* Each item is independent */
1930 PL_stack_sp = newsp;
1932 /* Stack values are safe: */
1934 POPSUB(cx,sv); /* release CV and @_ ... */
1938 PL_curpm = newpm; /* ... and pop $1 et al */
1944 return pop_return();
1951 register PERL_CONTEXT *cx;
1961 if (PL_op->op_flags & OPf_SPECIAL) {
1962 cxix = dopoptoloop(cxstack_ix);
1964 DIE(aTHX_ "Can't \"last\" outside a loop block");
1967 cxix = dopoptolabel(cPVOP->op_pv);
1969 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1971 if (cxix < cxstack_ix)
1976 switch (CxTYPE(cx)) {
1979 newsp = PL_stack_base + cx->blk_loop.resetsp;
1980 nextop = cx->blk_loop.last_op->op_next;
1984 nextop = pop_return();
1988 nextop = pop_return();
1992 nextop = pop_return();
1995 DIE(aTHX_ "panic: last");
1999 if (gimme == G_SCALAR) {
2001 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2002 ? *SP : sv_mortalcopy(*SP);
2004 *++newsp = &PL_sv_undef;
2006 else if (gimme == G_ARRAY) {
2007 while (++MARK <= SP) {
2008 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2009 ? *MARK : sv_mortalcopy(*MARK);
2010 TAINT_NOT; /* Each item is independent */
2016 /* Stack values are safe: */
2019 POPLOOP(cx); /* release loop vars ... */
2023 POPSUB(cx,sv); /* release CV and @_ ... */
2026 PL_curpm = newpm; /* ... and pop $1 et al */
2036 register PERL_CONTEXT *cx;
2039 if (PL_op->op_flags & OPf_SPECIAL) {
2040 cxix = dopoptoloop(cxstack_ix);
2042 DIE(aTHX_ "Can't \"next\" outside a loop block");
2045 cxix = dopoptolabel(cPVOP->op_pv);
2047 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2049 if (cxix < cxstack_ix)
2052 /* clear off anything above the scope we're re-entering, but
2053 * save the rest until after a possible continue block */
2054 inner = PL_scopestack_ix;
2056 if (PL_scopestack_ix < inner)
2057 leave_scope(PL_scopestack[PL_scopestack_ix]);
2058 return cx->blk_loop.next_op;
2064 register PERL_CONTEXT *cx;
2067 if (PL_op->op_flags & OPf_SPECIAL) {
2068 cxix = dopoptoloop(cxstack_ix);
2070 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2073 cxix = dopoptolabel(cPVOP->op_pv);
2075 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2077 if (cxix < cxstack_ix)
2081 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2082 LEAVE_SCOPE(oldsave);
2083 return cx->blk_loop.redo_op;
2087 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2091 static char too_deep[] = "Target of goto is too deeply nested";
2094 Perl_croak(aTHX_ too_deep);
2095 if (o->op_type == OP_LEAVE ||
2096 o->op_type == OP_SCOPE ||
2097 o->op_type == OP_LEAVELOOP ||
2098 o->op_type == OP_LEAVETRY)
2100 *ops++ = cUNOPo->op_first;
2102 Perl_croak(aTHX_ too_deep);
2105 if (o->op_flags & OPf_KIDS) {
2107 /* First try all the kids at this level, since that's likeliest. */
2108 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2109 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2110 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2113 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2114 if (kid == PL_lastgotoprobe)
2116 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2118 (ops[-1]->op_type != OP_NEXTSTATE &&
2119 ops[-1]->op_type != OP_DBSTATE)))
2121 if ((o = dofindlabel(kid, label, ops, oplimit)))
2140 register PERL_CONTEXT *cx;
2141 #define GOTO_DEPTH 64
2142 OP *enterops[GOTO_DEPTH];
2144 int do_dump = (PL_op->op_type == OP_DUMP);
2145 static char must_have_label[] = "goto must have label";
2148 if (PL_op->op_flags & OPf_STACKED) {
2152 /* This egregious kludge implements goto &subroutine */
2153 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2155 register PERL_CONTEXT *cx;
2156 CV* cv = (CV*)SvRV(sv);
2162 if (!CvROOT(cv) && !CvXSUB(cv)) {
2167 /* autoloaded stub? */
2168 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2170 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2171 GvNAMELEN(gv), FALSE);
2172 if (autogv && (cv = GvCV(autogv)))
2174 tmpstr = sv_newmortal();
2175 gv_efullname3(tmpstr, gv, Nullch);
2176 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2178 DIE(aTHX_ "Goto undefined subroutine");
2181 /* First do some returnish stuff. */
2182 cxix = dopoptosub(cxstack_ix);
2184 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2185 if (cxix < cxstack_ix)
2188 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2189 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2191 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2192 /* put @_ back onto stack */
2193 AV* av = cx->blk_sub.argarray;
2195 items = AvFILLp(av) + 1;
2197 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2198 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2199 PL_stack_sp += items;
2201 SvREFCNT_dec(GvAV(PL_defgv));
2202 GvAV(PL_defgv) = cx->blk_sub.savearray;
2203 #endif /* USE_THREADS */
2204 /* abandon @_ if it got reified */
2206 (void)sv_2mortal((SV*)av); /* delay until return */
2208 av_extend(av, items-1);
2209 AvFLAGS(av) = AVf_REIFY;
2210 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2213 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2216 av = (AV*)PL_curpad[0];
2218 av = GvAV(PL_defgv);
2220 items = AvFILLp(av) + 1;
2222 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2223 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2224 PL_stack_sp += items;
2226 if (CxTYPE(cx) == CXt_SUB &&
2227 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2228 SvREFCNT_dec(cx->blk_sub.cv);
2229 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2230 LEAVE_SCOPE(oldsave);
2232 /* Now do some callish stuff. */
2235 #ifdef PERL_XSUB_OLDSTYLE
2236 if (CvOLDSTYLE(cv)) {
2237 I32 (*fp3)(int,int,int);
2242 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2243 items = (*fp3)(CvXSUBANY(cv).any_i32,
2244 mark - PL_stack_base + 1,
2246 SP = PL_stack_base + items;
2249 #endif /* PERL_XSUB_OLDSTYLE */
2254 PL_stack_sp--; /* There is no cv arg. */
2255 /* Push a mark for the start of arglist */
2257 (void)(*CvXSUB(cv))(aTHXo_ cv);
2258 /* Pop the current context like a decent sub should */
2259 POPBLOCK(cx, PL_curpm);
2260 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2263 return pop_return();
2266 AV* padlist = CvPADLIST(cv);
2267 SV** svp = AvARRAY(padlist);
2268 if (CxTYPE(cx) == CXt_EVAL) {
2269 PL_in_eval = cx->blk_eval.old_in_eval;
2270 PL_eval_root = cx->blk_eval.old_eval_root;
2271 cx->cx_type = CXt_SUB;
2272 cx->blk_sub.hasargs = 0;
2274 cx->blk_sub.cv = cv;
2275 cx->blk_sub.olddepth = CvDEPTH(cv);
2277 if (CvDEPTH(cv) < 2)
2278 (void)SvREFCNT_inc(cv);
2279 else { /* save temporaries on recursion? */
2280 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2281 sub_crush_depth(cv);
2282 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2283 AV *newpad = newAV();
2284 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2285 I32 ix = AvFILLp((AV*)svp[1]);
2286 I32 names_fill = AvFILLp((AV*)svp[0]);
2287 svp = AvARRAY(svp[0]);
2288 for ( ;ix > 0; ix--) {
2289 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2290 char *name = SvPVX(svp[ix]);
2291 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2294 /* outer lexical or anon code */
2295 av_store(newpad, ix,
2296 SvREFCNT_inc(oldpad[ix]) );
2298 else { /* our own lexical */
2300 av_store(newpad, ix, sv = (SV*)newAV());
2301 else if (*name == '%')
2302 av_store(newpad, ix, sv = (SV*)newHV());
2304 av_store(newpad, ix, sv = NEWSV(0,0));
2308 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2309 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2312 av_store(newpad, ix, sv = NEWSV(0,0));
2316 if (cx->blk_sub.hasargs) {
2319 av_store(newpad, 0, (SV*)av);
2320 AvFLAGS(av) = AVf_REIFY;
2322 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2323 AvFILLp(padlist) = CvDEPTH(cv);
2324 svp = AvARRAY(padlist);
2328 if (!cx->blk_sub.hasargs) {
2329 AV* av = (AV*)PL_curpad[0];
2331 items = AvFILLp(av) + 1;
2333 /* Mark is at the end of the stack. */
2335 Copy(AvARRAY(av), SP + 1, items, SV*);
2340 #endif /* USE_THREADS */
2341 SAVEVPTR(PL_curpad);
2342 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2344 if (cx->blk_sub.hasargs)
2345 #endif /* USE_THREADS */
2347 AV* av = (AV*)PL_curpad[0];
2351 cx->blk_sub.savearray = GvAV(PL_defgv);
2352 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2353 #endif /* USE_THREADS */
2354 cx->blk_sub.oldcurpad = PL_curpad;
2355 cx->blk_sub.argarray = av;
2358 if (items >= AvMAX(av) + 1) {
2360 if (AvARRAY(av) != ary) {
2361 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2362 SvPVX(av) = (char*)ary;
2364 if (items >= AvMAX(av) + 1) {
2365 AvMAX(av) = items - 1;
2366 Renew(ary,items+1,SV*);
2368 SvPVX(av) = (char*)ary;
2371 Copy(mark,AvARRAY(av),items,SV*);
2372 AvFILLp(av) = items - 1;
2373 assert(!AvREAL(av));
2380 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2382 * We do not care about using sv to call CV;
2383 * it's for informational purposes only.
2385 SV *sv = GvSV(PL_DBsub);
2388 if (PERLDB_SUB_NN) {
2389 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2392 gv_efullname3(sv, CvGV(cv), Nullch);
2395 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2396 PUSHMARK( PL_stack_sp );
2397 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2401 RETURNOP(CvSTART(cv));
2405 label = SvPV(sv,n_a);
2406 if (!(do_dump || *label))
2407 DIE(aTHX_ must_have_label);
2410 else if (PL_op->op_flags & OPf_SPECIAL) {
2412 DIE(aTHX_ must_have_label);
2415 label = cPVOP->op_pv;
2417 if (label && *label) {
2422 PL_lastgotoprobe = 0;
2424 for (ix = cxstack_ix; ix >= 0; ix--) {
2426 switch (CxTYPE(cx)) {
2428 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2431 gotoprobe = cx->blk_oldcop->op_sibling;
2437 gotoprobe = cx->blk_oldcop->op_sibling;
2439 gotoprobe = PL_main_root;
2442 if (CvDEPTH(cx->blk_sub.cv)) {
2443 gotoprobe = CvROOT(cx->blk_sub.cv);
2449 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2452 DIE(aTHX_ "panic: goto");
2453 gotoprobe = PL_main_root;
2457 retop = dofindlabel(gotoprobe, label,
2458 enterops, enterops + GOTO_DEPTH);
2462 PL_lastgotoprobe = gotoprobe;
2465 DIE(aTHX_ "Can't find label %s", label);
2467 /* pop unwanted frames */
2469 if (ix < cxstack_ix) {
2476 oldsave = PL_scopestack[PL_scopestack_ix];
2477 LEAVE_SCOPE(oldsave);
2480 /* push wanted frames */
2482 if (*enterops && enterops[1]) {
2484 for (ix = 1; enterops[ix]; ix++) {
2485 PL_op = enterops[ix];
2486 /* Eventually we may want to stack the needed arguments
2487 * for each op. For now, we punt on the hard ones. */
2488 if (PL_op->op_type == OP_ENTERITER)
2489 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2490 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2498 if (!retop) retop = PL_main_start;
2500 PL_restartop = retop;
2501 PL_do_undump = TRUE;
2505 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2506 PL_do_undump = FALSE;
2522 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2526 PL_exit_flags |= PERL_EXIT_EXPECTED;
2528 PUSHs(&PL_sv_undef);
2536 NV value = SvNVx(GvSV(cCOP->cop_gv));
2537 register I32 match = I_32(value);
2540 if (((NV)match) > value)
2541 --match; /* was fractional--truncate other way */
2543 match -= cCOP->uop.scop.scop_offset;
2546 else if (match > cCOP->uop.scop.scop_max)
2547 match = cCOP->uop.scop.scop_max;
2548 PL_op = cCOP->uop.scop.scop_next[match];
2558 PL_op = PL_op->op_next; /* can't assume anything */
2561 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2562 match -= cCOP->uop.scop.scop_offset;
2565 else if (match > cCOP->uop.scop.scop_max)
2566 match = cCOP->uop.scop.scop_max;
2567 PL_op = cCOP->uop.scop.scop_next[match];
2576 S_save_lines(pTHX_ AV *array, SV *sv)
2578 register char *s = SvPVX(sv);
2579 register char *send = SvPVX(sv) + SvCUR(sv);
2581 register I32 line = 1;
2583 while (s && s < send) {
2584 SV *tmpstr = NEWSV(85,0);
2586 sv_upgrade(tmpstr, SVt_PVMG);
2587 t = strchr(s, '\n');
2593 sv_setpvn(tmpstr, s, t - s);
2594 av_store(array, line++, tmpstr);
2599 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2601 S_docatch_body(pTHX_ va_list args)
2603 return docatch_body();
2608 S_docatch_body(pTHX)
2615 S_docatch(pTHX_ OP *o)
2620 volatile PERL_SI *cursi = PL_curstackinfo;
2624 assert(CATCH_GET == TRUE);
2627 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2629 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2635 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2641 if (PL_restartop && cursi == PL_curstackinfo) {
2642 PL_op = PL_restartop;
2659 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2660 /* sv Text to convert to OP tree. */
2661 /* startop op_free() this to undo. */
2662 /* code Short string id of the caller. */
2664 dSP; /* Make POPBLOCK work. */
2667 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2671 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2672 char *tmpbuf = tbuf;
2678 /* switch to eval mode */
2680 if (PL_curcop == &PL_compiling) {
2681 SAVECOPSTASH_FREE(&PL_compiling);
2682 CopSTASH_set(&PL_compiling, PL_curstash);
2684 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2685 SV *sv = sv_newmortal();
2686 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2687 code, (unsigned long)++PL_evalseq,
2688 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2692 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2693 SAVECOPFILE_FREE(&PL_compiling);
2694 CopFILE_set(&PL_compiling, tmpbuf+2);
2695 SAVECOPLINE(&PL_compiling);
2696 CopLINE_set(&PL_compiling, 1);
2697 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2698 deleting the eval's FILEGV from the stash before gv_check() runs
2699 (i.e. before run-time proper). To work around the coredump that
2700 ensues, we always turn GvMULTI_on for any globals that were
2701 introduced within evals. See force_ident(). GSAR 96-10-12 */
2702 safestr = savepv(tmpbuf);
2703 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2705 #ifdef OP_IN_REGISTER
2713 PL_op->op_type = OP_ENTEREVAL;
2714 PL_op->op_flags = 0; /* Avoid uninit warning. */
2715 PUSHBLOCK(cx, CXt_EVAL, SP);
2716 PUSHEVAL(cx, 0, Nullgv);
2717 rop = doeval(G_SCALAR, startop);
2718 POPBLOCK(cx,PL_curpm);
2721 (*startop)->op_type = OP_NULL;
2722 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2724 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2726 if (PL_curcop == &PL_compiling)
2727 PL_compiling.op_private = PL_hints;
2728 #ifdef OP_IN_REGISTER
2734 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2736 S_doeval(pTHX_ int gimme, OP** startop)
2744 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2745 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2750 /* set up a scratch pad */
2753 SAVEVPTR(PL_curpad);
2754 SAVESPTR(PL_comppad);
2755 SAVESPTR(PL_comppad_name);
2756 SAVEI32(PL_comppad_name_fill);
2757 SAVEI32(PL_min_intro_pending);
2758 SAVEI32(PL_max_intro_pending);
2761 for (i = cxstack_ix - 1; i >= 0; i--) {
2762 PERL_CONTEXT *cx = &cxstack[i];
2763 if (CxTYPE(cx) == CXt_EVAL)
2765 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2766 caller = cx->blk_sub.cv;
2771 SAVESPTR(PL_compcv);
2772 PL_compcv = (CV*)NEWSV(1104,0);
2773 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2774 CvEVAL_on(PL_compcv);
2776 CvOWNER(PL_compcv) = 0;
2777 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2778 MUTEX_INIT(CvMUTEXP(PL_compcv));
2779 #endif /* USE_THREADS */
2781 PL_comppad = newAV();
2782 av_push(PL_comppad, Nullsv);
2783 PL_curpad = AvARRAY(PL_comppad);
2784 PL_comppad_name = newAV();
2785 PL_comppad_name_fill = 0;
2786 PL_min_intro_pending = 0;
2789 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2790 PL_curpad[0] = (SV*)newAV();
2791 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2792 #endif /* USE_THREADS */
2794 comppadlist = newAV();
2795 AvREAL_off(comppadlist);
2796 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2797 av_store(comppadlist, 1, (SV*)PL_comppad);
2798 CvPADLIST(PL_compcv) = comppadlist;
2801 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2803 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2806 SAVEFREESV(PL_compcv);
2808 /* make sure we compile in the right package */
2810 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2811 SAVESPTR(PL_curstash);
2812 PL_curstash = CopSTASH(PL_curcop);
2814 SAVESPTR(PL_beginav);
2815 PL_beginav = newAV();
2816 SAVEFREESV(PL_beginav);
2817 SAVEI32(PL_error_count);
2819 /* try to compile it */
2821 PL_eval_root = Nullop;
2823 PL_curcop = &PL_compiling;
2824 PL_curcop->cop_arybase = 0;
2825 SvREFCNT_dec(PL_rs);
2826 PL_rs = newSVpvn("\n", 1);
2827 if (saveop && saveop->op_flags & OPf_SPECIAL)
2828 PL_in_eval |= EVAL_KEEPERR;
2831 if (yyparse() || PL_error_count || !PL_eval_root) {
2835 I32 optype = 0; /* Might be reset by POPEVAL. */
2840 op_free(PL_eval_root);
2841 PL_eval_root = Nullop;
2843 SP = PL_stack_base + POPMARK; /* pop original mark */
2845 POPBLOCK(cx,PL_curpm);
2851 if (optype == OP_REQUIRE) {
2852 char* msg = SvPVx(ERRSV, n_a);
2853 DIE(aTHX_ "%sCompilation failed in require",
2854 *msg ? msg : "Unknown error\n");
2857 char* msg = SvPVx(ERRSV, n_a);
2859 POPBLOCK(cx,PL_curpm);
2861 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2862 (*msg ? msg : "Unknown error\n"));
2864 SvREFCNT_dec(PL_rs);
2865 PL_rs = SvREFCNT_inc(PL_nrs);
2867 MUTEX_LOCK(&PL_eval_mutex);
2869 COND_SIGNAL(&PL_eval_cond);
2870 MUTEX_UNLOCK(&PL_eval_mutex);
2871 #endif /* USE_THREADS */
2874 SvREFCNT_dec(PL_rs);
2875 PL_rs = SvREFCNT_inc(PL_nrs);
2876 CopLINE_set(&PL_compiling, 0);
2878 *startop = PL_eval_root;
2879 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2880 CvOUTSIDE(PL_compcv) = Nullcv;
2882 SAVEFREEOP(PL_eval_root);
2884 scalarvoid(PL_eval_root);
2885 else if (gimme & G_ARRAY)
2888 scalar(PL_eval_root);
2890 DEBUG_x(dump_eval());
2892 /* Register with debugger: */
2893 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2894 CV *cv = get_cv("DB::postponed", FALSE);
2898 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2900 call_sv((SV*)cv, G_DISCARD);
2904 /* compiled okay, so do it */
2906 CvDEPTH(PL_compcv) = 1;
2907 SP = PL_stack_base + POPMARK; /* pop original mark */
2908 PL_op = saveop; /* The caller may need it. */
2909 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2911 MUTEX_LOCK(&PL_eval_mutex);
2913 COND_SIGNAL(&PL_eval_cond);
2914 MUTEX_UNLOCK(&PL_eval_mutex);
2915 #endif /* USE_THREADS */
2917 RETURNOP(PL_eval_start);
2921 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2923 STRLEN namelen = strlen(name);
2926 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2927 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2928 char *pmc = SvPV_nolen(pmcsv);
2931 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2932 fp = PerlIO_open(name, mode);
2935 if (PerlLIO_stat(name, &pmstat) < 0 ||
2936 pmstat.st_mtime < pmcstat.st_mtime)
2938 fp = PerlIO_open(pmc, mode);
2941 fp = PerlIO_open(name, mode);
2944 SvREFCNT_dec(pmcsv);
2947 fp = PerlIO_open(name, mode);
2955 register PERL_CONTEXT *cx;
2960 SV *namesv = Nullsv;
2962 I32 gimme = G_SCALAR;
2963 PerlIO *tryrsfp = 0;
2965 int filter_has_file = 0;
2966 GV *filter_child_proc = 0;
2967 SV *filter_state = 0;
2972 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2973 UV rev = 0, ver = 0, sver = 0;
2975 U8 *s = (U8*)SvPVX(sv);
2976 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2978 rev = utf8_to_uv_chk(s, &len, 0);
2981 ver = utf8_to_uv_chk(s, &len, 0);
2984 sver = utf8_to_uv_chk(s, &len, 0);
2987 if (PERL_REVISION < rev
2988 || (PERL_REVISION == rev
2989 && (PERL_VERSION < ver
2990 || (PERL_VERSION == ver
2991 && PERL_SUBVERSION < sver))))
2993 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2994 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2995 PERL_VERSION, PERL_SUBVERSION);
2999 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3000 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3001 + ((NV)PERL_SUBVERSION/(NV)1000000)
3002 + 0.00000099 < SvNV(sv))
3006 NV nver = (nrev - rev) * 1000;
3007 UV ver = (UV)(nver + 0.0009);
3008 NV nsver = (nver - ver) * 1000;
3009 UV sver = (UV)(nsver + 0.0009);
3011 /* help out with the "use 5.6" confusion */
3012 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3013 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3014 "this is only v%d.%d.%d, stopped"
3015 " (did you mean v%"UVuf".%"UVuf".0?)",
3016 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3017 PERL_SUBVERSION, rev, ver/100);
3020 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3021 "this is only v%d.%d.%d, stopped",
3022 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3029 name = SvPV(sv, len);
3030 if (!(name && len > 0 && *name))
3031 DIE(aTHX_ "Null filename used");
3032 TAINT_PROPER("require");
3033 if (PL_op->op_type == OP_REQUIRE &&
3034 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3035 *svp != &PL_sv_undef)
3038 /* prepare to compile file */
3040 if (PERL_FILE_IS_ABSOLUTE(name)
3041 || (*name == '.' && (name[1] == '/' ||
3042 (name[1] == '.' && name[2] == '/'))))
3045 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3046 #ifdef MACOS_TRADITIONAL
3047 /* We consider paths of the form :a:b ambiguous and interpret them first
3048 as global then as local
3050 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3059 AV *ar = GvAVn(PL_incgv);
3063 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3066 namesv = NEWSV(806, 0);
3067 for (i = 0; i <= AvFILL(ar); i++) {
3068 SV *dirsv = *av_fetch(ar, i, TRUE);
3074 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3075 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3078 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3079 PTR2UV(SvANY(loader)), name);
3080 tryname = SvPVX(namesv);
3091 count = call_sv(loader, G_ARRAY);
3101 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3105 if (SvTYPE(arg) == SVt_PVGV) {
3106 IO *io = GvIO((GV *)arg);
3111 tryrsfp = IoIFP(io);
3112 if (IoTYPE(io) == IoTYPE_PIPE) {
3113 /* reading from a child process doesn't
3114 nest -- when returning from reading
3115 the inner module, the outer one is
3116 unreadable (closed?) I've tried to
3117 save the gv to manage the lifespan of
3118 the pipe, but this didn't help. XXX */
3119 filter_child_proc = (GV *)arg;
3120 (void)SvREFCNT_inc(filter_child_proc);
3123 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3124 PerlIO_close(IoOFP(io));
3136 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3138 (void)SvREFCNT_inc(filter_sub);
3141 filter_state = SP[i];
3142 (void)SvREFCNT_inc(filter_state);
3146 tryrsfp = PerlIO_open("/dev/null",
3160 filter_has_file = 0;
3161 if (filter_child_proc) {
3162 SvREFCNT_dec(filter_child_proc);
3163 filter_child_proc = 0;
3166 SvREFCNT_dec(filter_state);
3170 SvREFCNT_dec(filter_sub);
3175 char *dir = SvPVx(dirsv, n_a);
3176 #ifdef MACOS_TRADITIONAL
3178 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3182 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3184 sv_setpv(namesv, unixdir);
3185 sv_catpv(namesv, unixname);
3187 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3190 TAINT_PROPER("require");
3191 tryname = SvPVX(namesv);
3192 #ifdef MACOS_TRADITIONAL
3194 /* Convert slashes in the name part, but not the directory part, to colons */
3196 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3200 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3202 if (tryname[0] == '.' && tryname[1] == '/')
3210 SAVECOPFILE_FREE(&PL_compiling);
3211 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3212 SvREFCNT_dec(namesv);
3214 if (PL_op->op_type == OP_REQUIRE) {
3215 char *msgstr = name;
3216 if (namesv) { /* did we lookup @INC? */
3217 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3218 SV *dirmsgsv = NEWSV(0, 0);
3219 AV *ar = GvAVn(PL_incgv);
3221 sv_catpvn(msg, " in @INC", 8);
3222 if (instr(SvPVX(msg), ".h "))
3223 sv_catpv(msg, " (change .h to .ph maybe?)");
3224 if (instr(SvPVX(msg), ".ph "))
3225 sv_catpv(msg, " (did you run h2ph?)");
3226 sv_catpv(msg, " (@INC contains:");
3227 for (i = 0; i <= AvFILL(ar); i++) {
3228 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3229 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3230 sv_catsv(msg, dirmsgsv);
3232 sv_catpvn(msg, ")", 1);
3233 SvREFCNT_dec(dirmsgsv);
3234 msgstr = SvPV_nolen(msg);
3236 DIE(aTHX_ "Can't locate %s", msgstr);
3242 SETERRNO(0, SS$_NORMAL);
3244 /* Assume success here to prevent recursive requirement. */
3245 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3246 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3250 lex_start(sv_2mortal(newSVpvn("",0)));
3251 SAVEGENERICSV(PL_rsfp_filters);
3252 PL_rsfp_filters = Nullav;
3257 SAVESPTR(PL_compiling.cop_warnings);
3258 if (PL_dowarn & G_WARN_ALL_ON)
3259 PL_compiling.cop_warnings = pWARN_ALL ;
3260 else if (PL_dowarn & G_WARN_ALL_OFF)
3261 PL_compiling.cop_warnings = pWARN_NONE ;
3263 PL_compiling.cop_warnings = pWARN_STD ;
3265 if (filter_sub || filter_child_proc) {
3266 SV *datasv = filter_add(run_user_filter, Nullsv);
3267 IoLINES(datasv) = filter_has_file;
3268 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3269 IoTOP_GV(datasv) = (GV *)filter_state;
3270 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3273 /* switch to eval mode */
3274 push_return(PL_op->op_next);
3275 PUSHBLOCK(cx, CXt_EVAL, SP);
3276 PUSHEVAL(cx, name, Nullgv);
3278 SAVECOPLINE(&PL_compiling);
3279 CopLINE_set(&PL_compiling, 0);
3283 MUTEX_LOCK(&PL_eval_mutex);
3284 if (PL_eval_owner && PL_eval_owner != thr)
3285 while (PL_eval_owner)
3286 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3287 PL_eval_owner = thr;
3288 MUTEX_UNLOCK(&PL_eval_mutex);
3289 #endif /* USE_THREADS */
3290 return DOCATCH(doeval(G_SCALAR, NULL));
3295 return pp_require();
3301 register PERL_CONTEXT *cx;
3303 I32 gimme = GIMME_V, was = PL_sub_generation;
3304 char tbuf[TYPE_DIGITS(long) + 12];
3305 char *tmpbuf = tbuf;
3310 if (!SvPV(sv,len) || !len)
3312 TAINT_PROPER("eval");
3318 /* switch to eval mode */
3320 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3321 SV *sv = sv_newmortal();
3322 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3323 (unsigned long)++PL_evalseq,
3324 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3328 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3329 SAVECOPFILE_FREE(&PL_compiling);
3330 CopFILE_set(&PL_compiling, tmpbuf+2);
3331 SAVECOPLINE(&PL_compiling);
3332 CopLINE_set(&PL_compiling, 1);
3333 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3334 deleting the eval's FILEGV from the stash before gv_check() runs
3335 (i.e. before run-time proper). To work around the coredump that
3336 ensues, we always turn GvMULTI_on for any globals that were
3337 introduced within evals. See force_ident(). GSAR 96-10-12 */
3338 safestr = savepv(tmpbuf);
3339 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3341 PL_hints = PL_op->op_targ;
3342 SAVESPTR(PL_compiling.cop_warnings);
3343 if (specialWARN(PL_curcop->cop_warnings))
3344 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3346 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3347 SAVEFREESV(PL_compiling.cop_warnings);
3350 push_return(PL_op->op_next);
3351 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3352 PUSHEVAL(cx, 0, Nullgv);
3354 /* prepare to compile string */
3356 if (PERLDB_LINE && PL_curstash != PL_debstash)
3357 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3360 MUTEX_LOCK(&PL_eval_mutex);
3361 if (PL_eval_owner && PL_eval_owner != thr)
3362 while (PL_eval_owner)
3363 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3364 PL_eval_owner = thr;
3365 MUTEX_UNLOCK(&PL_eval_mutex);
3366 #endif /* USE_THREADS */
3367 ret = doeval(gimme, NULL);
3368 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3369 && ret != PL_op->op_next) { /* Successive compilation. */
3370 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3372 return DOCATCH(ret);
3382 register PERL_CONTEXT *cx;
3384 U8 save_flags = PL_op -> op_flags;
3389 retop = pop_return();
3392 if (gimme == G_VOID)
3394 else if (gimme == G_SCALAR) {
3397 if (SvFLAGS(TOPs) & SVs_TEMP)
3400 *MARK = sv_mortalcopy(TOPs);
3404 *MARK = &PL_sv_undef;
3409 /* in case LEAVE wipes old return values */
3410 for (mark = newsp + 1; mark <= SP; mark++) {
3411 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3412 *mark = sv_mortalcopy(*mark);
3413 TAINT_NOT; /* Each item is independent */
3417 PL_curpm = newpm; /* Don't pop $1 et al till now */
3419 if (AvFILLp(PL_comppad_name) >= 0)
3423 assert(CvDEPTH(PL_compcv) == 1);
3425 CvDEPTH(PL_compcv) = 0;
3428 if (optype == OP_REQUIRE &&
3429 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3431 /* Unassume the success we assumed earlier. */
3432 SV *nsv = cx->blk_eval.old_namesv;
3433 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3434 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3435 /* die_where() did LEAVE, or we won't be here */
3439 if (!(save_flags & OPf_SPECIAL))
3449 register PERL_CONTEXT *cx;
3450 I32 gimme = GIMME_V;
3455 push_return(cLOGOP->op_other->op_next);
3456 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3458 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3460 PL_in_eval = EVAL_INEVAL;
3463 return DOCATCH(PL_op->op_next);
3473 register PERL_CONTEXT *cx;
3481 if (gimme == G_VOID)
3483 else if (gimme == G_SCALAR) {
3486 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3489 *MARK = sv_mortalcopy(TOPs);
3493 *MARK = &PL_sv_undef;
3498 /* in case LEAVE wipes old return values */
3499 for (mark = newsp + 1; mark <= SP; mark++) {
3500 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3501 *mark = sv_mortalcopy(*mark);
3502 TAINT_NOT; /* Each item is independent */
3506 PL_curpm = newpm; /* Don't pop $1 et al till now */
3514 S_doparseform(pTHX_ SV *sv)
3517 register char *s = SvPV_force(sv, len);
3518 register char *send = s + len;
3519 register char *base;
3520 register I32 skipspaces = 0;
3523 bool postspace = FALSE;
3531 Perl_croak(aTHX_ "Null picture in formline");
3533 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3538 *fpc++ = FF_LINEMARK;
3539 noblank = repeat = FALSE;
3557 case ' ': case '\t':
3568 *fpc++ = FF_LITERAL;
3576 *fpc++ = skipspaces;
3580 *fpc++ = FF_NEWLINE;
3584 arg = fpc - linepc + 1;
3591 *fpc++ = FF_LINEMARK;
3592 noblank = repeat = FALSE;
3601 ischop = s[-1] == '^';
3607 arg = (s - base) - 1;
3609 *fpc++ = FF_LITERAL;
3618 *fpc++ = FF_LINEGLOB;
3620 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3621 arg = ischop ? 512 : 0;
3631 arg |= 256 + (s - f);
3633 *fpc++ = s - base; /* fieldsize for FETCH */
3634 *fpc++ = FF_DECIMAL;
3639 bool ismore = FALSE;
3642 while (*++s == '>') ;
3643 prespace = FF_SPACE;
3645 else if (*s == '|') {
3646 while (*++s == '|') ;
3647 prespace = FF_HALFSPACE;
3652 while (*++s == '<') ;
3655 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3659 *fpc++ = s - base; /* fieldsize for FETCH */
3661 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3679 { /* need to jump to the next word */
3681 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3682 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3683 s = SvPVX(sv) + SvCUR(sv) + z;
3685 Copy(fops, s, arg, U16);
3687 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3692 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3694 * The original code was written in conjunction with BSD Computer Software
3695 * Research Group at University of California, Berkeley.
3697 * See also: "Optimistic Merge Sort" (SODA '92)
3699 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3701 * The code can be distributed under the same terms as Perl itself.
3706 #include <sys/types.h>
3711 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3712 #define Safefree(VAR) free(VAR)
3713 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3714 #endif /* TESTHARNESS */
3716 typedef char * aptr; /* pointer for arithmetic on sizes */
3717 typedef SV * gptr; /* pointers in our lists */
3719 /* Binary merge internal sort, with a few special mods
3720 ** for the special perl environment it now finds itself in.
3722 ** Things that were once options have been hotwired
3723 ** to values suitable for this use. In particular, we'll always
3724 ** initialize looking for natural runs, we'll always produce stable
3725 ** output, and we'll always do Peter McIlroy's binary merge.
3728 /* Pointer types for arithmetic and storage and convenience casts */
3730 #define APTR(P) ((aptr)(P))
3731 #define GPTP(P) ((gptr *)(P))
3732 #define GPPP(P) ((gptr **)(P))
3735 /* byte offset from pointer P to (larger) pointer Q */
3736 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3738 #define PSIZE sizeof(gptr)
3740 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3743 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3744 #define PNBYTE(N) ((N) << (PSHIFT))
3745 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3747 /* Leave optimization to compiler */
3748 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3749 #define PNBYTE(N) ((N) * (PSIZE))
3750 #define PINDEX(P, N) (GPTP(P) + (N))
3753 /* Pointer into other corresponding to pointer into this */
3754 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3756 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3759 /* Runs are identified by a pointer in the auxilliary list.
3760 ** The pointer is at the start of the list,
3761 ** and it points to the start of the next list.
3762 ** NEXT is used as an lvalue, too.
3765 #define NEXT(P) (*GPPP(P))
3768 /* PTHRESH is the minimum number of pairs with the same sense to justify
3769 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3770 ** not just elements, so PTHRESH == 8 means a run of 16.
3775 /* RTHRESH is the number of elements in a run that must compare low
3776 ** to the low element from the opposing run before we justify
3777 ** doing a binary rampup instead of single stepping.
3778 ** In random input, N in a row low should only happen with
3779 ** probability 2^(1-N), so we can risk that we are dealing
3780 ** with orderly input without paying much when we aren't.
3787 ** Overview of algorithm and variables.
3788 ** The array of elements at list1 will be organized into runs of length 2,
3789 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3790 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3792 ** Unless otherwise specified, pair pointers address the first of two elements.
3794 ** b and b+1 are a pair that compare with sense ``sense''.
3795 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3797 ** p2 parallels b in the list2 array, where runs are defined by
3800 ** t represents the ``top'' of the adjacent pairs that might extend
3801 ** the run beginning at b. Usually, t addresses a pair
3802 ** that compares with opposite sense from (b,b+1).
3803 ** However, it may also address a singleton element at the end of list1,
3804 ** or it may be equal to ``last'', the first element beyond list1.
3806 ** r addresses the Nth pair following b. If this would be beyond t,
3807 ** we back it off to t. Only when r is less than t do we consider the
3808 ** run long enough to consider checking.
3810 ** q addresses a pair such that the pairs at b through q already form a run.
3811 ** Often, q will equal b, indicating we only are sure of the pair itself.
3812 ** However, a search on the previous cycle may have revealed a longer run,
3813 ** so q may be greater than b.
3815 ** p is used to work back from a candidate r, trying to reach q,
3816 ** which would mean b through r would be a run. If we discover such a run,
3817 ** we start q at r and try to push it further towards t.
3818 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3819 ** In any event, after the check (if any), we have two main cases.
3821 ** 1) Short run. b <= q < p <= r <= t.
3822 ** b through q is a run (perhaps trivial)
3823 ** q through p are uninteresting pairs
3824 ** p through r is a run
3826 ** 2) Long run. b < r <= q < t.
3827 ** b through q is a run (of length >= 2 * PTHRESH)
3829 ** Note that degenerate cases are not only possible, but likely.
3830 ** For example, if the pair following b compares with opposite sense,
3831 ** then b == q < p == r == t.
3836 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3839 register gptr *b, *p, *q, *t, *p2;
3840 register gptr c, *last, *r;
3844 last = PINDEX(b, nmemb);
3845 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3846 for (p2 = list2; b < last; ) {
3847 /* We just started, or just reversed sense.
3848 ** Set t at end of pairs with the prevailing sense.
3850 for (p = b+2, t = p; ++p < last; t = ++p) {
3851 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3854 /* Having laid out the playing field, look for long runs */
3856 p = r = b + (2 * PTHRESH);
3857 if (r >= t) p = r = t; /* too short to care about */
3859 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3862 /* b through r is a (long) run.
3863 ** Extend it as far as possible.
3866 while (((p += 2) < t) &&
3867 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3868 r = p = q + 2; /* no simple pairs, no after-run */
3871 if (q > b) { /* run of greater than 2 at b */
3874 /* pick up singleton, if possible */
3876 ((t + 1) == last) &&
3877 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3878 savep = r = p = q = last;
3879 p2 = NEXT(p2) = p2 + (p - b);
3880 if (sense) while (b < --p) {
3887 while (q < p) { /* simple pairs */
3888 p2 = NEXT(p2) = p2 + 2;
3895 if (((b = p) == t) && ((t+1) == last)) {
3907 /* Overview of bmerge variables:
3909 ** list1 and list2 address the main and auxiliary arrays.
3910 ** They swap identities after each merge pass.
3911 ** Base points to the original list1, so we can tell if
3912 ** the pointers ended up where they belonged (or must be copied).
3914 ** When we are merging two lists, f1 and f2 are the next elements
3915 ** on the respective lists. l1 and l2 mark the end of the lists.
3916 ** tp2 is the current location in the merged list.
3918 ** p1 records where f1 started.
3919 ** After the merge, a new descriptor is built there.
3921 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3922 ** It is used to identify and delimit the runs.
3924 ** In the heat of determining where q, the greater of the f1/f2 elements,
3925 ** belongs in the other list, b, t and p, represent bottom, top and probe
3926 ** locations, respectively, in the other list.
3927 ** They make convenient temporary pointers in other places.
3931 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
3935 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
3936 gptr *aux, *list2, *p2, *last;
3940 if (nmemb <= 1) return; /* sorted trivially */
3941 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
3943 dynprep(aTHX_ list1, list2, nmemb, cmp);
3944 last = PINDEX(list2, nmemb);
3945 while (NEXT(list2) != last) {
3946 /* More than one run remains. Do some merging to reduce runs. */
3948 for (tp2 = p2 = list2; p2 != last;) {
3949 /* The new first run begins where the old second list ended.
3950 ** Use the p2 ``parallel'' pointer to identify the end of the run.
3954 f2 = l1 = POTHER(t, list2, list1);
3955 if (t != last) t = NEXT(t);
3956 l2 = POTHER(t, list2, list1);
3958 while (f1 < l1 && f2 < l2) {
3959 /* If head 1 is larger than head 2, find ALL the elements
3960 ** in list 2 strictly less than head1, write them all,
3961 ** then head 1. Then compare the new heads, and repeat,
3962 ** until one or both lists are exhausted.
3964 ** In all comparisons (after establishing
3965 ** which head to merge) the item to merge
3966 ** (at pointer q) is the first operand of
3967 ** the comparison. When we want to know
3968 ** if ``q is strictly less than the other'',
3970 ** cmp(q, other) < 0
3971 ** because stability demands that we treat equality
3972 ** as high when q comes from l2, and as low when
3973 ** q was from l1. So we ask the question by doing
3974 ** cmp(q, other) <= sense
3975 ** and make sense == 0 when equality should look low,
3976 ** and -1 when equality should look high.
3980 if (cmp(aTHX_ *f1, *f2) <= 0) {
3981 q = f2; b = f1; t = l1;
3984 q = f1; b = f2; t = l2;
3991 ** Leave t at something strictly
3992 ** greater than q (or at the end of the list),
3993 ** and b at something strictly less than q.
3995 for (i = 1, run = 0 ;;) {
3996 if ((p = PINDEX(b, i)) >= t) {
3998 if (((p = PINDEX(t, -1)) > b) &&
3999 (cmp(aTHX_ *q, *p) <= sense))
4003 } else if (cmp(aTHX_ *q, *p) <= sense) {
4007 if (++run >= RTHRESH) i += i;
4011 /* q is known to follow b and must be inserted before t.
4012 ** Increment b, so the range of possibilities is [b,t).
4013 ** Round binary split down, to favor early appearance.
4014 ** Adjust b and t until q belongs just before t.
4019 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4020 if (cmp(aTHX_ *q, *p) <= sense) {
4026 /* Copy all the strictly low elements */
4029 FROMTOUPTO(f2, tp2, t);
4032 FROMTOUPTO(f1, tp2, t);
4038 /* Run out remaining list */
4040 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4041 } else FROMTOUPTO(f1, tp2, l1);
4042 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4047 last = PINDEX(list2, nmemb);
4049 if (base == list2) {
4050 last = PINDEX(list1, nmemb);
4051 FROMTOUPTO(list1, list2, last);
4066 sortcv(pTHXo_ SV *a, SV *b)
4069 I32 oldsaveix = PL_savestack_ix;
4070 I32 oldscopeix = PL_scopestack_ix;
4072 GvSV(PL_firstgv) = a;
4073 GvSV(PL_secondgv) = b;
4074 PL_stack_sp = PL_stack_base;
4077 if (PL_stack_sp != PL_stack_base + 1)
4078 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4079 if (!SvNIOKp(*PL_stack_sp))
4080 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4081 result = SvIV(*PL_stack_sp);
4082 while (PL_scopestack_ix > oldscopeix) {
4085 leave_scope(oldsaveix);
4090 sortcv_stacked(pTHXo_ SV *a, SV *b)
4093 I32 oldsaveix = PL_savestack_ix;
4094 I32 oldscopeix = PL_scopestack_ix;
4099 av = (AV*)PL_curpad[0];
4101 av = GvAV(PL_defgv);
4104 if (AvMAX(av) < 1) {
4105 SV** ary = AvALLOC(av);
4106 if (AvARRAY(av) != ary) {
4107 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4108 SvPVX(av) = (char*)ary;
4110 if (AvMAX(av) < 1) {
4113 SvPVX(av) = (char*)ary;
4120 PL_stack_sp = PL_stack_base;
4123 if (PL_stack_sp != PL_stack_base + 1)
4124 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4125 if (!SvNIOKp(*PL_stack_sp))
4126 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4127 result = SvIV(*PL_stack_sp);
4128 while (PL_scopestack_ix > oldscopeix) {
4131 leave_scope(oldsaveix);
4136 sortcv_xsub(pTHXo_ SV *a, SV *b)
4139 I32 oldsaveix = PL_savestack_ix;
4140 I32 oldscopeix = PL_scopestack_ix;
4142 CV *cv=(CV*)PL_sortcop;
4150 (void)(*CvXSUB(cv))(aTHXo_ cv);
4151 if (PL_stack_sp != PL_stack_base + 1)
4152 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4153 if (!SvNIOKp(*PL_stack_sp))
4154 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4155 result = SvIV(*PL_stack_sp);
4156 while (PL_scopestack_ix > oldscopeix) {
4159 leave_scope(oldsaveix);
4165 sv_ncmp(pTHXo_ SV *a, SV *b)
4169 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4173 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4177 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4179 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4181 if (PL_amagic_generation) { \
4182 if (SvAMAGIC(left)||SvAMAGIC(right))\
4183 *svp = amagic_call(left, \
4191 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4194 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4199 I32 i = SvIVX(tmpsv);
4209 return sv_ncmp(aTHXo_ a, b);
4213 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4216 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4221 I32 i = SvIVX(tmpsv);
4231 return sv_i_ncmp(aTHXo_ a, b);
4235 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4238 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4243 I32 i = SvIVX(tmpsv);
4253 return sv_cmp(str1, str2);
4257 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4260 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4265 I32 i = SvIVX(tmpsv);
4275 return sv_cmp_locale(str1, str2);
4279 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4281 SV *datasv = FILTER_DATA(idx);
4282 int filter_has_file = IoLINES(datasv);
4283 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4284 SV *filter_state = (SV *)IoTOP_GV(datasv);
4285 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4288 /* I was having segfault trouble under Linux 2.2.5 after a
4289 parse error occured. (Had to hack around it with a test
4290 for PL_error_count == 0.) Solaris doesn't segfault --
4291 not sure where the trouble is yet. XXX */
4293 if (filter_has_file) {
4294 len = FILTER_READ(idx+1, buf_sv, maxlen);
4297 if (filter_sub && len >= 0) {
4308 PUSHs(sv_2mortal(newSViv(maxlen)));
4310 PUSHs(filter_state);
4313 count = call_sv(filter_sub, G_SCALAR);
4329 IoLINES(datasv) = 0;
4330 if (filter_child_proc) {
4331 SvREFCNT_dec(filter_child_proc);
4332 IoFMT_GV(datasv) = Nullgv;
4335 SvREFCNT_dec(filter_state);
4336 IoTOP_GV(datasv) = Nullgv;
4339 SvREFCNT_dec(filter_sub);
4340 IoBOTTOM_GV(datasv) = Nullgv;
4342 filter_del(run_user_filter);
4351 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4353 return sv_cmp_locale(str1, str2);
4357 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4359 return sv_cmp(str1, str2);
4362 #endif /* PERL_OBJECT */