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);
1009 if ((PL_op->op_private & OPpFLIP_LINENUM)
1010 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1012 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1013 if (PL_op->op_flags & OPf_SPECIAL) {
1021 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1034 if (GIMME == G_ARRAY) {
1040 if (SvGMAGICAL(left))
1042 if (SvGMAGICAL(right))
1045 if (SvNIOKp(left) || !SvPOKp(left) ||
1046 SvNIOKp(right) || !SvPOKp(right) ||
1047 (looks_like_number(left) && *SvPVX(left) != '0' &&
1048 looks_like_number(right) && *SvPVX(right) != '0'))
1050 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1051 DIE(aTHX_ "Range iterator outside integer range");
1062 sv = sv_2mortal(newSViv(i++));
1067 SV *final = sv_mortalcopy(right);
1069 char *tmps = SvPV(final, len);
1071 sv = sv_mortalcopy(left);
1073 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1075 if (strEQ(SvPVX(sv),tmps))
1077 sv = sv_2mortal(newSVsv(sv));
1084 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1086 if ((PL_op->op_private & OPpFLIP_LINENUM)
1087 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1089 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1090 sv_catpv(targ, "E0");
1101 S_dopoptolabel(pTHX_ char *label)
1105 register PERL_CONTEXT *cx;
1107 for (i = cxstack_ix; i >= 0; i--) {
1109 switch (CxTYPE(cx)) {
1111 if (ckWARN(WARN_EXITING))
1112 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1113 PL_op_name[PL_op->op_type]);
1116 if (ckWARN(WARN_EXITING))
1117 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1118 PL_op_name[PL_op->op_type]);
1121 if (ckWARN(WARN_EXITING))
1122 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1123 PL_op_name[PL_op->op_type]);
1126 if (ckWARN(WARN_EXITING))
1127 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1128 PL_op_name[PL_op->op_type]);
1131 if (ckWARN(WARN_EXITING))
1132 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1133 PL_op_name[PL_op->op_type]);
1136 if (!cx->blk_loop.label ||
1137 strNE(label, cx->blk_loop.label) ) {
1138 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1139 (long)i, cx->blk_loop.label));
1142 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1150 Perl_dowantarray(pTHX)
1152 I32 gimme = block_gimme();
1153 return (gimme == G_VOID) ? G_SCALAR : gimme;
1157 Perl_block_gimme(pTHX)
1162 cxix = dopoptosub(cxstack_ix);
1166 switch (cxstack[cxix].blk_gimme) {
1174 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1181 S_dopoptosub(pTHX_ I32 startingblock)
1184 return dopoptosub_at(cxstack, startingblock);
1188 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1192 register PERL_CONTEXT *cx;
1193 for (i = startingblock; i >= 0; i--) {
1195 switch (CxTYPE(cx)) {
1201 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1209 S_dopoptoeval(pTHX_ I32 startingblock)
1213 register PERL_CONTEXT *cx;
1214 for (i = startingblock; i >= 0; i--) {
1216 switch (CxTYPE(cx)) {
1220 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1228 S_dopoptoloop(pTHX_ I32 startingblock)
1232 register PERL_CONTEXT *cx;
1233 for (i = startingblock; i >= 0; i--) {
1235 switch (CxTYPE(cx)) {
1237 if (ckWARN(WARN_EXITING))
1238 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1239 PL_op_name[PL_op->op_type]);
1242 if (ckWARN(WARN_EXITING))
1243 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1244 PL_op_name[PL_op->op_type]);
1247 if (ckWARN(WARN_EXITING))
1248 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1249 PL_op_name[PL_op->op_type]);
1252 if (ckWARN(WARN_EXITING))
1253 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1254 PL_op_name[PL_op->op_type]);
1257 if (ckWARN(WARN_EXITING))
1258 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1259 PL_op_name[PL_op->op_type]);
1262 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1270 Perl_dounwind(pTHX_ I32 cxix)
1273 register PERL_CONTEXT *cx;
1276 while (cxstack_ix > cxix) {
1278 cx = &cxstack[cxstack_ix];
1279 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1280 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1281 /* Note: we don't need to restore the base context info till the end. */
1282 switch (CxTYPE(cx)) {
1285 continue; /* not break */
1307 * Closures mentioned at top level of eval cannot be referenced
1308 * again, and their presence indirectly causes a memory leak.
1309 * (Note that the fact that compcv and friends are still set here
1310 * is, AFAIK, an accident.) --Chip
1312 * XXX need to get comppad et al from eval's cv rather than
1313 * relying on the incidental global values.
1316 S_free_closures(pTHX)
1319 SV **svp = AvARRAY(PL_comppad_name);
1321 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1323 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1325 svp[ix] = &PL_sv_undef;
1329 SvREFCNT_dec(CvOUTSIDE(sv));
1330 CvOUTSIDE(sv) = Nullcv;
1343 Perl_qerror(pTHX_ SV *err)
1346 sv_catsv(ERRSV, err);
1348 sv_catsv(PL_errors, err);
1350 Perl_warn(aTHX_ "%"SVf, err);
1355 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1360 register PERL_CONTEXT *cx;
1365 if (PL_in_eval & EVAL_KEEPERR) {
1366 static char prefix[] = "\t(in cleanup) ";
1371 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1374 if (*e != *message || strNE(e,message))
1378 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1379 sv_catpvn(err, prefix, sizeof(prefix)-1);
1380 sv_catpvn(err, message, msglen);
1381 if (ckWARN(WARN_MISC)) {
1382 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1383 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1388 sv_setpvn(ERRSV, message, msglen);
1391 message = SvPVx(ERRSV, msglen);
1393 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1394 && PL_curstackinfo->si_prev)
1403 if (cxix < cxstack_ix)
1406 POPBLOCK(cx,PL_curpm);
1407 if (CxTYPE(cx) != CXt_EVAL) {
1408 PerlIO_write(Perl_error_log, "panic: die ", 11);
1409 PerlIO_write(Perl_error_log, message, msglen);
1414 if (gimme == G_SCALAR)
1415 *++newsp = &PL_sv_undef;
1416 PL_stack_sp = newsp;
1420 if (optype == OP_REQUIRE) {
1421 char* msg = SvPVx(ERRSV, n_a);
1422 DIE(aTHX_ "%sCompilation failed in require",
1423 *msg ? msg : "Unknown error\n");
1425 return pop_return();
1429 message = SvPVx(ERRSV, msglen);
1432 /* SFIO can really mess with your errno */
1435 PerlIO *serr = Perl_error_log;
1437 PerlIO_write(serr, message, msglen);
1438 (void)PerlIO_flush(serr);
1451 if (SvTRUE(left) != SvTRUE(right))
1463 RETURNOP(cLOGOP->op_other);
1472 RETURNOP(cLOGOP->op_other);
1478 register I32 cxix = dopoptosub(cxstack_ix);
1479 register PERL_CONTEXT *cx;
1480 register PERL_CONTEXT *ccstack = cxstack;
1481 PERL_SI *top_si = PL_curstackinfo;
1492 /* we may be in a higher stacklevel, so dig down deeper */
1493 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1494 top_si = top_si->si_prev;
1495 ccstack = top_si->si_cxstack;
1496 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1499 if (GIMME != G_ARRAY)
1503 if (PL_DBsub && cxix >= 0 &&
1504 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1508 cxix = dopoptosub_at(ccstack, cxix - 1);
1511 cx = &ccstack[cxix];
1512 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1513 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1514 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1515 field below is defined for any cx. */
1516 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1517 cx = &ccstack[dbcxix];
1520 stashname = CopSTASHPV(cx->blk_oldcop);
1521 if (GIMME != G_ARRAY) {
1523 PUSHs(&PL_sv_undef);
1526 sv_setpv(TARG, stashname);
1533 PUSHs(&PL_sv_undef);
1535 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1536 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1537 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1540 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1541 /* So is ccstack[dbcxix]. */
1543 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1544 PUSHs(sv_2mortal(sv));
1545 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1548 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1549 PUSHs(sv_2mortal(newSViv(0)));
1551 gimme = (I32)cx->blk_gimme;
1552 if (gimme == G_VOID)
1553 PUSHs(&PL_sv_undef);
1555 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1556 if (CxTYPE(cx) == CXt_EVAL) {
1558 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1559 PUSHs(cx->blk_eval.cur_text);
1563 else if (cx->blk_eval.old_namesv) {
1564 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1567 /* eval BLOCK (try blocks have old_namesv == 0) */
1569 PUSHs(&PL_sv_undef);
1570 PUSHs(&PL_sv_undef);
1574 PUSHs(&PL_sv_undef);
1575 PUSHs(&PL_sv_undef);
1577 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1578 && CopSTASH_eq(PL_curcop, PL_debstash))
1580 AV *ary = cx->blk_sub.argarray;
1581 int off = AvARRAY(ary) - AvALLOC(ary);
1585 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1588 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1591 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1592 av_extend(PL_dbargs, AvFILLp(ary) + off);
1593 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1594 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1596 /* XXX only hints propagated via op_private are currently
1597 * visible (others are not easily accessible, since they
1598 * use the global PL_hints) */
1599 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1600 HINT_PRIVATE_MASK)));
1603 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1605 if (old_warnings == pWARN_NONE ||
1606 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1607 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1608 else if (old_warnings == pWARN_ALL ||
1609 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1610 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1612 mask = newSVsv(old_warnings);
1613 PUSHs(sv_2mortal(mask));
1628 sv_reset(tmps, CopSTASH(PL_curcop));
1640 PL_curcop = (COP*)PL_op;
1641 TAINT_NOT; /* Each statement is presumed innocent */
1642 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1645 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1649 register PERL_CONTEXT *cx;
1650 I32 gimme = G_ARRAY;
1657 DIE(aTHX_ "No DB::DB routine defined");
1659 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1671 push_return(PL_op->op_next);
1672 PUSHBLOCK(cx, CXt_SUB, SP);
1675 (void)SvREFCNT_inc(cv);
1676 SAVEVPTR(PL_curpad);
1677 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1678 RETURNOP(CvSTART(cv));
1692 register PERL_CONTEXT *cx;
1693 I32 gimme = GIMME_V;
1695 U32 cxtype = CXt_LOOP;
1704 if (PL_op->op_flags & OPf_SPECIAL) {
1706 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1707 SAVEGENERICSV(*svp);
1711 #endif /* USE_THREADS */
1712 if (PL_op->op_targ) {
1713 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1716 iterdata = (void*)PL_op->op_targ;
1717 cxtype |= CXp_PADVAR;
1722 svp = &GvSV(gv); /* symbol table variable */
1723 SAVEGENERICSV(*svp);
1726 iterdata = (void*)gv;
1732 PUSHBLOCK(cx, cxtype, SP);
1734 PUSHLOOP(cx, iterdata, MARK);
1736 PUSHLOOP(cx, svp, MARK);
1738 if (PL_op->op_flags & OPf_STACKED) {
1739 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1740 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1742 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1743 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1744 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1745 looks_like_number((SV*)cx->blk_loop.iterary) &&
1746 *SvPVX(cx->blk_loop.iterary) != '0'))
1748 if (SvNV(sv) < IV_MIN ||
1749 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1750 DIE(aTHX_ "Range iterator outside integer range");
1751 cx->blk_loop.iterix = SvIV(sv);
1752 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1755 cx->blk_loop.iterlval = newSVsv(sv);
1759 cx->blk_loop.iterary = PL_curstack;
1760 AvFILLp(PL_curstack) = SP - PL_stack_base;
1761 cx->blk_loop.iterix = MARK - PL_stack_base;
1770 register PERL_CONTEXT *cx;
1771 I32 gimme = GIMME_V;
1777 PUSHBLOCK(cx, CXt_LOOP, SP);
1778 PUSHLOOP(cx, 0, SP);
1786 register PERL_CONTEXT *cx;
1794 newsp = PL_stack_base + cx->blk_loop.resetsp;
1797 if (gimme == G_VOID)
1799 else if (gimme == G_SCALAR) {
1801 *++newsp = sv_mortalcopy(*SP);
1803 *++newsp = &PL_sv_undef;
1807 *++newsp = sv_mortalcopy(*++mark);
1808 TAINT_NOT; /* Each item is independent */
1814 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1815 PL_curpm = newpm; /* ... and pop $1 et al */
1827 register PERL_CONTEXT *cx;
1828 bool popsub2 = FALSE;
1829 bool clear_errsv = FALSE;
1836 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1837 if (cxstack_ix == PL_sortcxix
1838 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1840 if (cxstack_ix > PL_sortcxix)
1841 dounwind(PL_sortcxix);
1842 AvARRAY(PL_curstack)[1] = *SP;
1843 PL_stack_sp = PL_stack_base + 1;
1848 cxix = dopoptosub(cxstack_ix);
1850 DIE(aTHX_ "Can't return outside a subroutine");
1851 if (cxix < cxstack_ix)
1855 switch (CxTYPE(cx)) {
1860 if (!(PL_in_eval & EVAL_KEEPERR))
1865 if (AvFILLp(PL_comppad_name) >= 0)
1868 if (optype == OP_REQUIRE &&
1869 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1871 /* Unassume the success we assumed earlier. */
1872 SV *nsv = cx->blk_eval.old_namesv;
1873 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1874 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1881 DIE(aTHX_ "panic: return");
1885 if (gimme == G_SCALAR) {
1888 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1890 *++newsp = SvREFCNT_inc(*SP);
1895 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1897 *++newsp = sv_mortalcopy(sv);
1902 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1905 *++newsp = sv_mortalcopy(*SP);
1908 *++newsp = &PL_sv_undef;
1910 else if (gimme == G_ARRAY) {
1911 while (++MARK <= SP) {
1912 *++newsp = (popsub2 && SvTEMP(*MARK))
1913 ? *MARK : sv_mortalcopy(*MARK);
1914 TAINT_NOT; /* Each item is independent */
1917 PL_stack_sp = newsp;
1919 /* Stack values are safe: */
1921 POPSUB(cx,sv); /* release CV and @_ ... */
1925 PL_curpm = newpm; /* ... and pop $1 et al */
1931 return pop_return();
1938 register PERL_CONTEXT *cx;
1948 if (PL_op->op_flags & OPf_SPECIAL) {
1949 cxix = dopoptoloop(cxstack_ix);
1951 DIE(aTHX_ "Can't \"last\" outside a loop block");
1954 cxix = dopoptolabel(cPVOP->op_pv);
1956 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1958 if (cxix < cxstack_ix)
1963 switch (CxTYPE(cx)) {
1966 newsp = PL_stack_base + cx->blk_loop.resetsp;
1967 nextop = cx->blk_loop.last_op->op_next;
1971 nextop = pop_return();
1975 nextop = pop_return();
1979 nextop = pop_return();
1982 DIE(aTHX_ "panic: last");
1986 if (gimme == G_SCALAR) {
1988 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1989 ? *SP : sv_mortalcopy(*SP);
1991 *++newsp = &PL_sv_undef;
1993 else if (gimme == G_ARRAY) {
1994 while (++MARK <= SP) {
1995 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1996 ? *MARK : sv_mortalcopy(*MARK);
1997 TAINT_NOT; /* Each item is independent */
2003 /* Stack values are safe: */
2006 POPLOOP(cx); /* release loop vars ... */
2010 POPSUB(cx,sv); /* release CV and @_ ... */
2013 PL_curpm = newpm; /* ... and pop $1 et al */
2023 register PERL_CONTEXT *cx;
2026 if (PL_op->op_flags & OPf_SPECIAL) {
2027 cxix = dopoptoloop(cxstack_ix);
2029 DIE(aTHX_ "Can't \"next\" outside a loop block");
2032 cxix = dopoptolabel(cPVOP->op_pv);
2034 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2036 if (cxix < cxstack_ix)
2039 /* clear off anything above the scope we're re-entering, but
2040 * save the rest until after a possible continue block */
2041 inner = PL_scopestack_ix;
2043 if (PL_scopestack_ix < inner)
2044 leave_scope(PL_scopestack[PL_scopestack_ix]);
2045 return cx->blk_loop.next_op;
2051 register PERL_CONTEXT *cx;
2054 if (PL_op->op_flags & OPf_SPECIAL) {
2055 cxix = dopoptoloop(cxstack_ix);
2057 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2060 cxix = dopoptolabel(cPVOP->op_pv);
2062 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2064 if (cxix < cxstack_ix)
2068 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2069 LEAVE_SCOPE(oldsave);
2070 return cx->blk_loop.redo_op;
2074 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2078 static char too_deep[] = "Target of goto is too deeply nested";
2081 Perl_croak(aTHX_ too_deep);
2082 if (o->op_type == OP_LEAVE ||
2083 o->op_type == OP_SCOPE ||
2084 o->op_type == OP_LEAVELOOP ||
2085 o->op_type == OP_LEAVETRY)
2087 *ops++ = cUNOPo->op_first;
2089 Perl_croak(aTHX_ too_deep);
2092 if (o->op_flags & OPf_KIDS) {
2094 /* First try all the kids at this level, since that's likeliest. */
2095 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2096 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2097 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2100 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2101 if (kid == PL_lastgotoprobe)
2103 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2105 (ops[-1]->op_type != OP_NEXTSTATE &&
2106 ops[-1]->op_type != OP_DBSTATE)))
2108 if ((o = dofindlabel(kid, label, ops, oplimit)))
2127 register PERL_CONTEXT *cx;
2128 #define GOTO_DEPTH 64
2129 OP *enterops[GOTO_DEPTH];
2131 int do_dump = (PL_op->op_type == OP_DUMP);
2132 static char must_have_label[] = "goto must have label";
2135 if (PL_op->op_flags & OPf_STACKED) {
2139 /* This egregious kludge implements goto &subroutine */
2140 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2142 register PERL_CONTEXT *cx;
2143 CV* cv = (CV*)SvRV(sv);
2149 if (!CvROOT(cv) && !CvXSUB(cv)) {
2154 /* autoloaded stub? */
2155 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2157 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2158 GvNAMELEN(gv), FALSE);
2159 if (autogv && (cv = GvCV(autogv)))
2161 tmpstr = sv_newmortal();
2162 gv_efullname3(tmpstr, gv, Nullch);
2163 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2165 DIE(aTHX_ "Goto undefined subroutine");
2168 /* First do some returnish stuff. */
2169 cxix = dopoptosub(cxstack_ix);
2171 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2172 if (cxix < cxstack_ix)
2175 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2176 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2178 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2179 /* put @_ back onto stack */
2180 AV* av = cx->blk_sub.argarray;
2182 items = AvFILLp(av) + 1;
2184 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2185 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2186 PL_stack_sp += items;
2188 SvREFCNT_dec(GvAV(PL_defgv));
2189 GvAV(PL_defgv) = cx->blk_sub.savearray;
2190 #endif /* USE_THREADS */
2191 /* abandon @_ if it got reified */
2193 (void)sv_2mortal((SV*)av); /* delay until return */
2195 av_extend(av, items-1);
2196 AvFLAGS(av) = AVf_REIFY;
2197 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2200 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2203 av = (AV*)PL_curpad[0];
2205 av = GvAV(PL_defgv);
2207 items = AvFILLp(av) + 1;
2209 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2210 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2211 PL_stack_sp += items;
2213 if (CxTYPE(cx) == CXt_SUB &&
2214 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2215 SvREFCNT_dec(cx->blk_sub.cv);
2216 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2217 LEAVE_SCOPE(oldsave);
2219 /* Now do some callish stuff. */
2222 #ifdef PERL_XSUB_OLDSTYLE
2223 if (CvOLDSTYLE(cv)) {
2224 I32 (*fp3)(int,int,int);
2229 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2230 items = (*fp3)(CvXSUBANY(cv).any_i32,
2231 mark - PL_stack_base + 1,
2233 SP = PL_stack_base + items;
2236 #endif /* PERL_XSUB_OLDSTYLE */
2241 PL_stack_sp--; /* There is no cv arg. */
2242 /* Push a mark for the start of arglist */
2244 (void)(*CvXSUB(cv))(aTHXo_ cv);
2245 /* Pop the current context like a decent sub should */
2246 POPBLOCK(cx, PL_curpm);
2247 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2250 return pop_return();
2253 AV* padlist = CvPADLIST(cv);
2254 SV** svp = AvARRAY(padlist);
2255 if (CxTYPE(cx) == CXt_EVAL) {
2256 PL_in_eval = cx->blk_eval.old_in_eval;
2257 PL_eval_root = cx->blk_eval.old_eval_root;
2258 cx->cx_type = CXt_SUB;
2259 cx->blk_sub.hasargs = 0;
2261 cx->blk_sub.cv = cv;
2262 cx->blk_sub.olddepth = CvDEPTH(cv);
2264 if (CvDEPTH(cv) < 2)
2265 (void)SvREFCNT_inc(cv);
2266 else { /* save temporaries on recursion? */
2267 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2268 sub_crush_depth(cv);
2269 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2270 AV *newpad = newAV();
2271 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2272 I32 ix = AvFILLp((AV*)svp[1]);
2273 I32 names_fill = AvFILLp((AV*)svp[0]);
2274 svp = AvARRAY(svp[0]);
2275 for ( ;ix > 0; ix--) {
2276 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2277 char *name = SvPVX(svp[ix]);
2278 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2281 /* outer lexical or anon code */
2282 av_store(newpad, ix,
2283 SvREFCNT_inc(oldpad[ix]) );
2285 else { /* our own lexical */
2287 av_store(newpad, ix, sv = (SV*)newAV());
2288 else if (*name == '%')
2289 av_store(newpad, ix, sv = (SV*)newHV());
2291 av_store(newpad, ix, sv = NEWSV(0,0));
2295 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2296 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2299 av_store(newpad, ix, sv = NEWSV(0,0));
2303 if (cx->blk_sub.hasargs) {
2306 av_store(newpad, 0, (SV*)av);
2307 AvFLAGS(av) = AVf_REIFY;
2309 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2310 AvFILLp(padlist) = CvDEPTH(cv);
2311 svp = AvARRAY(padlist);
2315 if (!cx->blk_sub.hasargs) {
2316 AV* av = (AV*)PL_curpad[0];
2318 items = AvFILLp(av) + 1;
2320 /* Mark is at the end of the stack. */
2322 Copy(AvARRAY(av), SP + 1, items, SV*);
2327 #endif /* USE_THREADS */
2328 SAVEVPTR(PL_curpad);
2329 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2331 if (cx->blk_sub.hasargs)
2332 #endif /* USE_THREADS */
2334 AV* av = (AV*)PL_curpad[0];
2338 cx->blk_sub.savearray = GvAV(PL_defgv);
2339 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2340 #endif /* USE_THREADS */
2341 cx->blk_sub.oldcurpad = PL_curpad;
2342 cx->blk_sub.argarray = av;
2345 if (items >= AvMAX(av) + 1) {
2347 if (AvARRAY(av) != ary) {
2348 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2349 SvPVX(av) = (char*)ary;
2351 if (items >= AvMAX(av) + 1) {
2352 AvMAX(av) = items - 1;
2353 Renew(ary,items+1,SV*);
2355 SvPVX(av) = (char*)ary;
2358 Copy(mark,AvARRAY(av),items,SV*);
2359 AvFILLp(av) = items - 1;
2360 assert(!AvREAL(av));
2367 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2369 * We do not care about using sv to call CV;
2370 * it's for informational purposes only.
2372 SV *sv = GvSV(PL_DBsub);
2375 if (PERLDB_SUB_NN) {
2376 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2379 gv_efullname3(sv, CvGV(cv), Nullch);
2382 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2383 PUSHMARK( PL_stack_sp );
2384 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2388 RETURNOP(CvSTART(cv));
2392 label = SvPV(sv,n_a);
2393 if (!(do_dump || *label))
2394 DIE(aTHX_ must_have_label);
2397 else if (PL_op->op_flags & OPf_SPECIAL) {
2399 DIE(aTHX_ must_have_label);
2402 label = cPVOP->op_pv;
2404 if (label && *label) {
2409 PL_lastgotoprobe = 0;
2411 for (ix = cxstack_ix; ix >= 0; ix--) {
2413 switch (CxTYPE(cx)) {
2415 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2418 gotoprobe = cx->blk_oldcop->op_sibling;
2424 gotoprobe = cx->blk_oldcop->op_sibling;
2426 gotoprobe = PL_main_root;
2429 if (CvDEPTH(cx->blk_sub.cv)) {
2430 gotoprobe = CvROOT(cx->blk_sub.cv);
2436 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2439 DIE(aTHX_ "panic: goto");
2440 gotoprobe = PL_main_root;
2444 retop = dofindlabel(gotoprobe, label,
2445 enterops, enterops + GOTO_DEPTH);
2449 PL_lastgotoprobe = gotoprobe;
2452 DIE(aTHX_ "Can't find label %s", label);
2454 /* pop unwanted frames */
2456 if (ix < cxstack_ix) {
2463 oldsave = PL_scopestack[PL_scopestack_ix];
2464 LEAVE_SCOPE(oldsave);
2467 /* push wanted frames */
2469 if (*enterops && enterops[1]) {
2471 for (ix = 1; enterops[ix]; ix++) {
2472 PL_op = enterops[ix];
2473 /* Eventually we may want to stack the needed arguments
2474 * for each op. For now, we punt on the hard ones. */
2475 if (PL_op->op_type == OP_ENTERITER)
2476 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2477 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2485 if (!retop) retop = PL_main_start;
2487 PL_restartop = retop;
2488 PL_do_undump = TRUE;
2492 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2493 PL_do_undump = FALSE;
2509 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2513 PL_exit_flags |= PERL_EXIT_EXPECTED;
2515 PUSHs(&PL_sv_undef);
2523 NV value = SvNVx(GvSV(cCOP->cop_gv));
2524 register I32 match = I_32(value);
2527 if (((NV)match) > value)
2528 --match; /* was fractional--truncate other way */
2530 match -= cCOP->uop.scop.scop_offset;
2533 else if (match > cCOP->uop.scop.scop_max)
2534 match = cCOP->uop.scop.scop_max;
2535 PL_op = cCOP->uop.scop.scop_next[match];
2545 PL_op = PL_op->op_next; /* can't assume anything */
2548 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2549 match -= cCOP->uop.scop.scop_offset;
2552 else if (match > cCOP->uop.scop.scop_max)
2553 match = cCOP->uop.scop.scop_max;
2554 PL_op = cCOP->uop.scop.scop_next[match];
2563 S_save_lines(pTHX_ AV *array, SV *sv)
2565 register char *s = SvPVX(sv);
2566 register char *send = SvPVX(sv) + SvCUR(sv);
2568 register I32 line = 1;
2570 while (s && s < send) {
2571 SV *tmpstr = NEWSV(85,0);
2573 sv_upgrade(tmpstr, SVt_PVMG);
2574 t = strchr(s, '\n');
2580 sv_setpvn(tmpstr, s, t - s);
2581 av_store(array, line++, tmpstr);
2586 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2588 S_docatch_body(pTHX_ va_list args)
2590 return docatch_body();
2595 S_docatch_body(pTHX)
2602 S_docatch(pTHX_ OP *o)
2607 volatile PERL_SI *cursi = PL_curstackinfo;
2611 assert(CATCH_GET == TRUE);
2614 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2616 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2622 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2628 if (PL_restartop && cursi == PL_curstackinfo) {
2629 PL_op = PL_restartop;
2646 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2647 /* sv Text to convert to OP tree. */
2648 /* startop op_free() this to undo. */
2649 /* code Short string id of the caller. */
2651 dSP; /* Make POPBLOCK work. */
2654 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2658 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2659 char *tmpbuf = tbuf;
2665 /* switch to eval mode */
2667 if (PL_curcop == &PL_compiling) {
2668 SAVECOPSTASH_FREE(&PL_compiling);
2669 CopSTASH_set(&PL_compiling, PL_curstash);
2671 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2672 SV *sv = sv_newmortal();
2673 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2674 code, (unsigned long)++PL_evalseq,
2675 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2679 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2680 SAVECOPFILE_FREE(&PL_compiling);
2681 CopFILE_set(&PL_compiling, tmpbuf+2);
2682 SAVECOPLINE(&PL_compiling);
2683 CopLINE_set(&PL_compiling, 1);
2684 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2685 deleting the eval's FILEGV from the stash before gv_check() runs
2686 (i.e. before run-time proper). To work around the coredump that
2687 ensues, we always turn GvMULTI_on for any globals that were
2688 introduced within evals. See force_ident(). GSAR 96-10-12 */
2689 safestr = savepv(tmpbuf);
2690 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2692 #ifdef OP_IN_REGISTER
2700 PL_op->op_type = OP_ENTEREVAL;
2701 PL_op->op_flags = 0; /* Avoid uninit warning. */
2702 PUSHBLOCK(cx, CXt_EVAL, SP);
2703 PUSHEVAL(cx, 0, Nullgv);
2704 rop = doeval(G_SCALAR, startop);
2705 POPBLOCK(cx,PL_curpm);
2708 (*startop)->op_type = OP_NULL;
2709 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2711 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2713 if (PL_curcop == &PL_compiling)
2714 PL_compiling.op_private = PL_hints;
2715 #ifdef OP_IN_REGISTER
2721 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2723 S_doeval(pTHX_ int gimme, OP** startop)
2731 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2732 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2737 /* set up a scratch pad */
2740 SAVEVPTR(PL_curpad);
2741 SAVESPTR(PL_comppad);
2742 SAVESPTR(PL_comppad_name);
2743 SAVEI32(PL_comppad_name_fill);
2744 SAVEI32(PL_min_intro_pending);
2745 SAVEI32(PL_max_intro_pending);
2748 for (i = cxstack_ix - 1; i >= 0; i--) {
2749 PERL_CONTEXT *cx = &cxstack[i];
2750 if (CxTYPE(cx) == CXt_EVAL)
2752 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2753 caller = cx->blk_sub.cv;
2758 SAVESPTR(PL_compcv);
2759 PL_compcv = (CV*)NEWSV(1104,0);
2760 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2761 CvEVAL_on(PL_compcv);
2763 CvOWNER(PL_compcv) = 0;
2764 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2765 MUTEX_INIT(CvMUTEXP(PL_compcv));
2766 #endif /* USE_THREADS */
2768 PL_comppad = newAV();
2769 av_push(PL_comppad, Nullsv);
2770 PL_curpad = AvARRAY(PL_comppad);
2771 PL_comppad_name = newAV();
2772 PL_comppad_name_fill = 0;
2773 PL_min_intro_pending = 0;
2776 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2777 PL_curpad[0] = (SV*)newAV();
2778 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2779 #endif /* USE_THREADS */
2781 comppadlist = newAV();
2782 AvREAL_off(comppadlist);
2783 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2784 av_store(comppadlist, 1, (SV*)PL_comppad);
2785 CvPADLIST(PL_compcv) = comppadlist;
2788 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2790 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2793 SAVEFREESV(PL_compcv);
2795 /* make sure we compile in the right package */
2797 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2798 SAVESPTR(PL_curstash);
2799 PL_curstash = CopSTASH(PL_curcop);
2801 SAVESPTR(PL_beginav);
2802 PL_beginav = newAV();
2803 SAVEFREESV(PL_beginav);
2804 SAVEI32(PL_error_count);
2806 /* try to compile it */
2808 PL_eval_root = Nullop;
2810 PL_curcop = &PL_compiling;
2811 PL_curcop->cop_arybase = 0;
2812 SvREFCNT_dec(PL_rs);
2813 PL_rs = newSVpvn("\n", 1);
2814 if (saveop && saveop->op_flags & OPf_SPECIAL)
2815 PL_in_eval |= EVAL_KEEPERR;
2818 if (yyparse() || PL_error_count || !PL_eval_root) {
2822 I32 optype = 0; /* Might be reset by POPEVAL. */
2827 op_free(PL_eval_root);
2828 PL_eval_root = Nullop;
2830 SP = PL_stack_base + POPMARK; /* pop original mark */
2832 POPBLOCK(cx,PL_curpm);
2838 if (optype == OP_REQUIRE) {
2839 char* msg = SvPVx(ERRSV, n_a);
2840 DIE(aTHX_ "%sCompilation failed in require",
2841 *msg ? msg : "Unknown error\n");
2844 char* msg = SvPVx(ERRSV, n_a);
2846 POPBLOCK(cx,PL_curpm);
2848 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2849 (*msg ? msg : "Unknown error\n"));
2851 SvREFCNT_dec(PL_rs);
2852 PL_rs = SvREFCNT_inc(PL_nrs);
2854 MUTEX_LOCK(&PL_eval_mutex);
2856 COND_SIGNAL(&PL_eval_cond);
2857 MUTEX_UNLOCK(&PL_eval_mutex);
2858 #endif /* USE_THREADS */
2861 SvREFCNT_dec(PL_rs);
2862 PL_rs = SvREFCNT_inc(PL_nrs);
2863 CopLINE_set(&PL_compiling, 0);
2865 *startop = PL_eval_root;
2866 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2867 CvOUTSIDE(PL_compcv) = Nullcv;
2869 SAVEFREEOP(PL_eval_root);
2871 scalarvoid(PL_eval_root);
2872 else if (gimme & G_ARRAY)
2875 scalar(PL_eval_root);
2877 DEBUG_x(dump_eval());
2879 /* Register with debugger: */
2880 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2881 CV *cv = get_cv("DB::postponed", FALSE);
2885 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2887 call_sv((SV*)cv, G_DISCARD);
2891 /* compiled okay, so do it */
2893 CvDEPTH(PL_compcv) = 1;
2894 SP = PL_stack_base + POPMARK; /* pop original mark */
2895 PL_op = saveop; /* The caller may need it. */
2896 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2898 MUTEX_LOCK(&PL_eval_mutex);
2900 COND_SIGNAL(&PL_eval_cond);
2901 MUTEX_UNLOCK(&PL_eval_mutex);
2902 #endif /* USE_THREADS */
2904 RETURNOP(PL_eval_start);
2908 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2910 STRLEN namelen = strlen(name);
2913 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2914 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2915 char *pmc = SvPV_nolen(pmcsv);
2918 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2919 fp = PerlIO_open(name, mode);
2922 if (PerlLIO_stat(name, &pmstat) < 0 ||
2923 pmstat.st_mtime < pmcstat.st_mtime)
2925 fp = PerlIO_open(pmc, mode);
2928 fp = PerlIO_open(name, mode);
2931 SvREFCNT_dec(pmcsv);
2934 fp = PerlIO_open(name, mode);
2942 register PERL_CONTEXT *cx;
2947 SV *namesv = Nullsv;
2949 I32 gimme = G_SCALAR;
2950 PerlIO *tryrsfp = 0;
2952 int filter_has_file = 0;
2953 GV *filter_child_proc = 0;
2954 SV *filter_state = 0;
2959 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2960 UV rev = 0, ver = 0, sver = 0;
2962 U8 *s = (U8*)SvPVX(sv);
2963 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2965 rev = utf8_to_uv_chk(s, &len, 0);
2968 ver = utf8_to_uv_chk(s, &len, 0);
2971 sver = utf8_to_uv_chk(s, &len, 0);
2974 if (PERL_REVISION < rev
2975 || (PERL_REVISION == rev
2976 && (PERL_VERSION < ver
2977 || (PERL_VERSION == ver
2978 && PERL_SUBVERSION < sver))))
2980 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2981 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2982 PERL_VERSION, PERL_SUBVERSION);
2986 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2987 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2988 + ((NV)PERL_SUBVERSION/(NV)1000000)
2989 + 0.00000099 < SvNV(sv))
2993 NV nver = (nrev - rev) * 1000;
2994 UV ver = (UV)(nver + 0.0009);
2995 NV nsver = (nver - ver) * 1000;
2996 UV sver = (UV)(nsver + 0.0009);
2998 /* help out with the "use 5.6" confusion */
2999 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3000 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3001 "this is only v%d.%d.%d, stopped"
3002 " (did you mean v%"UVuf".%"UVuf".0?)",
3003 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3004 PERL_SUBVERSION, rev, ver/100);
3007 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3008 "this is only v%d.%d.%d, stopped",
3009 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3016 name = SvPV(sv, len);
3017 if (!(name && len > 0 && *name))
3018 DIE(aTHX_ "Null filename used");
3019 TAINT_PROPER("require");
3020 if (PL_op->op_type == OP_REQUIRE &&
3021 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3022 *svp != &PL_sv_undef)
3025 /* prepare to compile file */
3027 if (PERL_FILE_IS_ABSOLUTE(name)
3028 || (*name == '.' && (name[1] == '/' ||
3029 (name[1] == '.' && name[2] == '/'))))
3032 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3033 #ifdef MACOS_TRADITIONAL
3034 /* We consider paths of the form :a:b ambiguous and interpret them first
3035 as global then as local
3037 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3046 AV *ar = GvAVn(PL_incgv);
3050 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3053 namesv = NEWSV(806, 0);
3054 for (i = 0; i <= AvFILL(ar); i++) {
3055 SV *dirsv = *av_fetch(ar, i, TRUE);
3061 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3062 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3065 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3066 PTR2UV(SvANY(loader)), name);
3067 tryname = SvPVX(namesv);
3078 count = call_sv(loader, G_ARRAY);
3088 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3092 if (SvTYPE(arg) == SVt_PVGV) {
3093 IO *io = GvIO((GV *)arg);
3098 tryrsfp = IoIFP(io);
3099 if (IoTYPE(io) == IoTYPE_PIPE) {
3100 /* reading from a child process doesn't
3101 nest -- when returning from reading
3102 the inner module, the outer one is
3103 unreadable (closed?) I've tried to
3104 save the gv to manage the lifespan of
3105 the pipe, but this didn't help. XXX */
3106 filter_child_proc = (GV *)arg;
3107 (void)SvREFCNT_inc(filter_child_proc);
3110 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3111 PerlIO_close(IoOFP(io));
3123 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3125 (void)SvREFCNT_inc(filter_sub);
3128 filter_state = SP[i];
3129 (void)SvREFCNT_inc(filter_state);
3133 tryrsfp = PerlIO_open("/dev/null",
3147 filter_has_file = 0;
3148 if (filter_child_proc) {
3149 SvREFCNT_dec(filter_child_proc);
3150 filter_child_proc = 0;
3153 SvREFCNT_dec(filter_state);
3157 SvREFCNT_dec(filter_sub);
3162 char *dir = SvPVx(dirsv, n_a);
3163 #ifdef MACOS_TRADITIONAL
3165 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3169 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3171 sv_setpv(namesv, unixdir);
3172 sv_catpv(namesv, unixname);
3174 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3177 TAINT_PROPER("require");
3178 tryname = SvPVX(namesv);
3179 #ifdef MACOS_TRADITIONAL
3181 /* Convert slashes in the name part, but not the directory part, to colons */
3183 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3187 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3189 if (tryname[0] == '.' && tryname[1] == '/')
3197 SAVECOPFILE_FREE(&PL_compiling);
3198 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3199 SvREFCNT_dec(namesv);
3201 if (PL_op->op_type == OP_REQUIRE) {
3202 char *msgstr = name;
3203 if (namesv) { /* did we lookup @INC? */
3204 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3205 SV *dirmsgsv = NEWSV(0, 0);
3206 AV *ar = GvAVn(PL_incgv);
3208 sv_catpvn(msg, " in @INC", 8);
3209 if (instr(SvPVX(msg), ".h "))
3210 sv_catpv(msg, " (change .h to .ph maybe?)");
3211 if (instr(SvPVX(msg), ".ph "))
3212 sv_catpv(msg, " (did you run h2ph?)");
3213 sv_catpv(msg, " (@INC contains:");
3214 for (i = 0; i <= AvFILL(ar); i++) {
3215 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3216 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3217 sv_catsv(msg, dirmsgsv);
3219 sv_catpvn(msg, ")", 1);
3220 SvREFCNT_dec(dirmsgsv);
3221 msgstr = SvPV_nolen(msg);
3223 DIE(aTHX_ "Can't locate %s", msgstr);
3229 SETERRNO(0, SS$_NORMAL);
3231 /* Assume success here to prevent recursive requirement. */
3232 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3233 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3237 lex_start(sv_2mortal(newSVpvn("",0)));
3238 SAVEGENERICSV(PL_rsfp_filters);
3239 PL_rsfp_filters = Nullav;
3244 SAVESPTR(PL_compiling.cop_warnings);
3245 if (PL_dowarn & G_WARN_ALL_ON)
3246 PL_compiling.cop_warnings = pWARN_ALL ;
3247 else if (PL_dowarn & G_WARN_ALL_OFF)
3248 PL_compiling.cop_warnings = pWARN_NONE ;
3250 PL_compiling.cop_warnings = pWARN_STD ;
3252 if (filter_sub || filter_child_proc) {
3253 SV *datasv = filter_add(run_user_filter, Nullsv);
3254 IoLINES(datasv) = filter_has_file;
3255 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3256 IoTOP_GV(datasv) = (GV *)filter_state;
3257 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3260 /* switch to eval mode */
3261 push_return(PL_op->op_next);
3262 PUSHBLOCK(cx, CXt_EVAL, SP);
3263 PUSHEVAL(cx, name, Nullgv);
3265 SAVECOPLINE(&PL_compiling);
3266 CopLINE_set(&PL_compiling, 0);
3270 MUTEX_LOCK(&PL_eval_mutex);
3271 if (PL_eval_owner && PL_eval_owner != thr)
3272 while (PL_eval_owner)
3273 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3274 PL_eval_owner = thr;
3275 MUTEX_UNLOCK(&PL_eval_mutex);
3276 #endif /* USE_THREADS */
3277 return DOCATCH(doeval(G_SCALAR, NULL));
3282 return pp_require();
3288 register PERL_CONTEXT *cx;
3290 I32 gimme = GIMME_V, was = PL_sub_generation;
3291 char tbuf[TYPE_DIGITS(long) + 12];
3292 char *tmpbuf = tbuf;
3297 if (!SvPV(sv,len) || !len)
3299 TAINT_PROPER("eval");
3305 /* switch to eval mode */
3307 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3308 SV *sv = sv_newmortal();
3309 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3310 (unsigned long)++PL_evalseq,
3311 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3315 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3316 SAVECOPFILE_FREE(&PL_compiling);
3317 CopFILE_set(&PL_compiling, tmpbuf+2);
3318 SAVECOPLINE(&PL_compiling);
3319 CopLINE_set(&PL_compiling, 1);
3320 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3321 deleting the eval's FILEGV from the stash before gv_check() runs
3322 (i.e. before run-time proper). To work around the coredump that
3323 ensues, we always turn GvMULTI_on for any globals that were
3324 introduced within evals. See force_ident(). GSAR 96-10-12 */
3325 safestr = savepv(tmpbuf);
3326 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3328 PL_hints = PL_op->op_targ;
3329 SAVESPTR(PL_compiling.cop_warnings);
3330 if (specialWARN(PL_curcop->cop_warnings))
3331 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3333 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3334 SAVEFREESV(PL_compiling.cop_warnings);
3337 push_return(PL_op->op_next);
3338 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3339 PUSHEVAL(cx, 0, Nullgv);
3341 /* prepare to compile string */
3343 if (PERLDB_LINE && PL_curstash != PL_debstash)
3344 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3347 MUTEX_LOCK(&PL_eval_mutex);
3348 if (PL_eval_owner && PL_eval_owner != thr)
3349 while (PL_eval_owner)
3350 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3351 PL_eval_owner = thr;
3352 MUTEX_UNLOCK(&PL_eval_mutex);
3353 #endif /* USE_THREADS */
3354 ret = doeval(gimme, NULL);
3355 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3356 && ret != PL_op->op_next) { /* Successive compilation. */
3357 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3359 return DOCATCH(ret);
3369 register PERL_CONTEXT *cx;
3371 U8 save_flags = PL_op -> op_flags;
3376 retop = pop_return();
3379 if (gimme == G_VOID)
3381 else if (gimme == G_SCALAR) {
3384 if (SvFLAGS(TOPs) & SVs_TEMP)
3387 *MARK = sv_mortalcopy(TOPs);
3391 *MARK = &PL_sv_undef;
3396 /* in case LEAVE wipes old return values */
3397 for (mark = newsp + 1; mark <= SP; mark++) {
3398 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3399 *mark = sv_mortalcopy(*mark);
3400 TAINT_NOT; /* Each item is independent */
3404 PL_curpm = newpm; /* Don't pop $1 et al till now */
3406 if (AvFILLp(PL_comppad_name) >= 0)
3410 assert(CvDEPTH(PL_compcv) == 1);
3412 CvDEPTH(PL_compcv) = 0;
3415 if (optype == OP_REQUIRE &&
3416 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3418 /* Unassume the success we assumed earlier. */
3419 SV *nsv = cx->blk_eval.old_namesv;
3420 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3421 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3422 /* die_where() did LEAVE, or we won't be here */
3426 if (!(save_flags & OPf_SPECIAL))
3436 register PERL_CONTEXT *cx;
3437 I32 gimme = GIMME_V;
3442 push_return(cLOGOP->op_other->op_next);
3443 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3445 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3447 PL_in_eval = EVAL_INEVAL;
3450 return DOCATCH(PL_op->op_next);
3460 register PERL_CONTEXT *cx;
3468 if (gimme == G_VOID)
3470 else if (gimme == G_SCALAR) {
3473 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3476 *MARK = sv_mortalcopy(TOPs);
3480 *MARK = &PL_sv_undef;
3485 /* in case LEAVE wipes old return values */
3486 for (mark = newsp + 1; mark <= SP; mark++) {
3487 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3488 *mark = sv_mortalcopy(*mark);
3489 TAINT_NOT; /* Each item is independent */
3493 PL_curpm = newpm; /* Don't pop $1 et al till now */
3501 S_doparseform(pTHX_ SV *sv)
3504 register char *s = SvPV_force(sv, len);
3505 register char *send = s + len;
3506 register char *base;
3507 register I32 skipspaces = 0;
3510 bool postspace = FALSE;
3518 Perl_croak(aTHX_ "Null picture in formline");
3520 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3525 *fpc++ = FF_LINEMARK;
3526 noblank = repeat = FALSE;
3544 case ' ': case '\t':
3555 *fpc++ = FF_LITERAL;
3563 *fpc++ = skipspaces;
3567 *fpc++ = FF_NEWLINE;
3571 arg = fpc - linepc + 1;
3578 *fpc++ = FF_LINEMARK;
3579 noblank = repeat = FALSE;
3588 ischop = s[-1] == '^';
3594 arg = (s - base) - 1;
3596 *fpc++ = FF_LITERAL;
3605 *fpc++ = FF_LINEGLOB;
3607 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3608 arg = ischop ? 512 : 0;
3618 arg |= 256 + (s - f);
3620 *fpc++ = s - base; /* fieldsize for FETCH */
3621 *fpc++ = FF_DECIMAL;
3626 bool ismore = FALSE;
3629 while (*++s == '>') ;
3630 prespace = FF_SPACE;
3632 else if (*s == '|') {
3633 while (*++s == '|') ;
3634 prespace = FF_HALFSPACE;
3639 while (*++s == '<') ;
3642 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3646 *fpc++ = s - base; /* fieldsize for FETCH */
3648 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3666 { /* need to jump to the next word */
3668 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3669 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3670 s = SvPVX(sv) + SvCUR(sv) + z;
3672 Copy(fops, s, arg, U16);
3674 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3679 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3681 * The original code was written in conjunction with BSD Computer Software
3682 * Research Group at University of California, Berkeley.
3684 * See also: "Optimistic Merge Sort" (SODA '92)
3686 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3688 * The code can be distributed under the same terms as Perl itself.
3693 #include <sys/types.h>
3698 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3699 #define Safefree(VAR) free(VAR)
3700 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3701 #endif /* TESTHARNESS */
3703 typedef char * aptr; /* pointer for arithmetic on sizes */
3704 typedef SV * gptr; /* pointers in our lists */
3706 /* Binary merge internal sort, with a few special mods
3707 ** for the special perl environment it now finds itself in.
3709 ** Things that were once options have been hotwired
3710 ** to values suitable for this use. In particular, we'll always
3711 ** initialize looking for natural runs, we'll always produce stable
3712 ** output, and we'll always do Peter McIlroy's binary merge.
3715 /* Pointer types for arithmetic and storage and convenience casts */
3717 #define APTR(P) ((aptr)(P))
3718 #define GPTP(P) ((gptr *)(P))
3719 #define GPPP(P) ((gptr **)(P))
3722 /* byte offset from pointer P to (larger) pointer Q */
3723 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3725 #define PSIZE sizeof(gptr)
3727 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3730 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3731 #define PNBYTE(N) ((N) << (PSHIFT))
3732 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3734 /* Leave optimization to compiler */
3735 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3736 #define PNBYTE(N) ((N) * (PSIZE))
3737 #define PINDEX(P, N) (GPTP(P) + (N))
3740 /* Pointer into other corresponding to pointer into this */
3741 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3743 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3746 /* Runs are identified by a pointer in the auxilliary list.
3747 ** The pointer is at the start of the list,
3748 ** and it points to the start of the next list.
3749 ** NEXT is used as an lvalue, too.
3752 #define NEXT(P) (*GPPP(P))
3755 /* PTHRESH is the minimum number of pairs with the same sense to justify
3756 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3757 ** not just elements, so PTHRESH == 8 means a run of 16.
3762 /* RTHRESH is the number of elements in a run that must compare low
3763 ** to the low element from the opposing run before we justify
3764 ** doing a binary rampup instead of single stepping.
3765 ** In random input, N in a row low should only happen with
3766 ** probability 2^(1-N), so we can risk that we are dealing
3767 ** with orderly input without paying much when we aren't.
3774 ** Overview of algorithm and variables.
3775 ** The array of elements at list1 will be organized into runs of length 2,
3776 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3777 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3779 ** Unless otherwise specified, pair pointers address the first of two elements.
3781 ** b and b+1 are a pair that compare with sense ``sense''.
3782 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3784 ** p2 parallels b in the list2 array, where runs are defined by
3787 ** t represents the ``top'' of the adjacent pairs that might extend
3788 ** the run beginning at b. Usually, t addresses a pair
3789 ** that compares with opposite sense from (b,b+1).
3790 ** However, it may also address a singleton element at the end of list1,
3791 ** or it may be equal to ``last'', the first element beyond list1.
3793 ** r addresses the Nth pair following b. If this would be beyond t,
3794 ** we back it off to t. Only when r is less than t do we consider the
3795 ** run long enough to consider checking.
3797 ** q addresses a pair such that the pairs at b through q already form a run.
3798 ** Often, q will equal b, indicating we only are sure of the pair itself.
3799 ** However, a search on the previous cycle may have revealed a longer run,
3800 ** so q may be greater than b.
3802 ** p is used to work back from a candidate r, trying to reach q,
3803 ** which would mean b through r would be a run. If we discover such a run,
3804 ** we start q at r and try to push it further towards t.
3805 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3806 ** In any event, after the check (if any), we have two main cases.
3808 ** 1) Short run. b <= q < p <= r <= t.
3809 ** b through q is a run (perhaps trivial)
3810 ** q through p are uninteresting pairs
3811 ** p through r is a run
3813 ** 2) Long run. b < r <= q < t.
3814 ** b through q is a run (of length >= 2 * PTHRESH)
3816 ** Note that degenerate cases are not only possible, but likely.
3817 ** For example, if the pair following b compares with opposite sense,
3818 ** then b == q < p == r == t.
3823 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3826 register gptr *b, *p, *q, *t, *p2;
3827 register gptr c, *last, *r;
3831 last = PINDEX(b, nmemb);
3832 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3833 for (p2 = list2; b < last; ) {
3834 /* We just started, or just reversed sense.
3835 ** Set t at end of pairs with the prevailing sense.
3837 for (p = b+2, t = p; ++p < last; t = ++p) {
3838 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3841 /* Having laid out the playing field, look for long runs */
3843 p = r = b + (2 * PTHRESH);
3844 if (r >= t) p = r = t; /* too short to care about */
3846 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3849 /* b through r is a (long) run.
3850 ** Extend it as far as possible.
3853 while (((p += 2) < t) &&
3854 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3855 r = p = q + 2; /* no simple pairs, no after-run */
3858 if (q > b) { /* run of greater than 2 at b */
3861 /* pick up singleton, if possible */
3863 ((t + 1) == last) &&
3864 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3865 savep = r = p = q = last;
3866 p2 = NEXT(p2) = p2 + (p - b);
3867 if (sense) while (b < --p) {
3874 while (q < p) { /* simple pairs */
3875 p2 = NEXT(p2) = p2 + 2;
3882 if (((b = p) == t) && ((t+1) == last)) {
3894 /* Overview of bmerge variables:
3896 ** list1 and list2 address the main and auxiliary arrays.
3897 ** They swap identities after each merge pass.
3898 ** Base points to the original list1, so we can tell if
3899 ** the pointers ended up where they belonged (or must be copied).
3901 ** When we are merging two lists, f1 and f2 are the next elements
3902 ** on the respective lists. l1 and l2 mark the end of the lists.
3903 ** tp2 is the current location in the merged list.
3905 ** p1 records where f1 started.
3906 ** After the merge, a new descriptor is built there.
3908 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3909 ** It is used to identify and delimit the runs.
3911 ** In the heat of determining where q, the greater of the f1/f2 elements,
3912 ** belongs in the other list, b, t and p, represent bottom, top and probe
3913 ** locations, respectively, in the other list.
3914 ** They make convenient temporary pointers in other places.
3918 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
3922 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
3923 gptr *aux, *list2, *p2, *last;
3927 if (nmemb <= 1) return; /* sorted trivially */
3928 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
3930 dynprep(aTHX_ list1, list2, nmemb, cmp);
3931 last = PINDEX(list2, nmemb);
3932 while (NEXT(list2) != last) {
3933 /* More than one run remains. Do some merging to reduce runs. */
3935 for (tp2 = p2 = list2; p2 != last;) {
3936 /* The new first run begins where the old second list ended.
3937 ** Use the p2 ``parallel'' pointer to identify the end of the run.
3941 f2 = l1 = POTHER(t, list2, list1);
3942 if (t != last) t = NEXT(t);
3943 l2 = POTHER(t, list2, list1);
3945 while (f1 < l1 && f2 < l2) {
3946 /* If head 1 is larger than head 2, find ALL the elements
3947 ** in list 2 strictly less than head1, write them all,
3948 ** then head 1. Then compare the new heads, and repeat,
3949 ** until one or both lists are exhausted.
3951 ** In all comparisons (after establishing
3952 ** which head to merge) the item to merge
3953 ** (at pointer q) is the first operand of
3954 ** the comparison. When we want to know
3955 ** if ``q is strictly less than the other'',
3957 ** cmp(q, other) < 0
3958 ** because stability demands that we treat equality
3959 ** as high when q comes from l2, and as low when
3960 ** q was from l1. So we ask the question by doing
3961 ** cmp(q, other) <= sense
3962 ** and make sense == 0 when equality should look low,
3963 ** and -1 when equality should look high.
3967 if (cmp(aTHX_ *f1, *f2) <= 0) {
3968 q = f2; b = f1; t = l1;
3971 q = f1; b = f2; t = l2;
3978 ** Leave t at something strictly
3979 ** greater than q (or at the end of the list),
3980 ** and b at something strictly less than q.
3982 for (i = 1, run = 0 ;;) {
3983 if ((p = PINDEX(b, i)) >= t) {
3985 if (((p = PINDEX(t, -1)) > b) &&
3986 (cmp(aTHX_ *q, *p) <= sense))
3990 } else if (cmp(aTHX_ *q, *p) <= sense) {
3994 if (++run >= RTHRESH) i += i;
3998 /* q is known to follow b and must be inserted before t.
3999 ** Increment b, so the range of possibilities is [b,t).
4000 ** Round binary split down, to favor early appearance.
4001 ** Adjust b and t until q belongs just before t.
4006 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4007 if (cmp(aTHX_ *q, *p) <= sense) {
4013 /* Copy all the strictly low elements */
4016 FROMTOUPTO(f2, tp2, t);
4019 FROMTOUPTO(f1, tp2, t);
4025 /* Run out remaining list */
4027 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4028 } else FROMTOUPTO(f1, tp2, l1);
4029 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4034 last = PINDEX(list2, nmemb);
4036 if (base == list2) {
4037 last = PINDEX(list1, nmemb);
4038 FROMTOUPTO(list1, list2, last);
4053 sortcv(pTHXo_ SV *a, SV *b)
4056 I32 oldsaveix = PL_savestack_ix;
4057 I32 oldscopeix = PL_scopestack_ix;
4059 GvSV(PL_firstgv) = a;
4060 GvSV(PL_secondgv) = b;
4061 PL_stack_sp = PL_stack_base;
4064 if (PL_stack_sp != PL_stack_base + 1)
4065 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4066 if (!SvNIOKp(*PL_stack_sp))
4067 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4068 result = SvIV(*PL_stack_sp);
4069 while (PL_scopestack_ix > oldscopeix) {
4072 leave_scope(oldsaveix);
4077 sortcv_stacked(pTHXo_ SV *a, SV *b)
4080 I32 oldsaveix = PL_savestack_ix;
4081 I32 oldscopeix = PL_scopestack_ix;
4086 av = (AV*)PL_curpad[0];
4088 av = GvAV(PL_defgv);
4091 if (AvMAX(av) < 1) {
4092 SV** ary = AvALLOC(av);
4093 if (AvARRAY(av) != ary) {
4094 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4095 SvPVX(av) = (char*)ary;
4097 if (AvMAX(av) < 1) {
4100 SvPVX(av) = (char*)ary;
4107 PL_stack_sp = PL_stack_base;
4110 if (PL_stack_sp != PL_stack_base + 1)
4111 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4112 if (!SvNIOKp(*PL_stack_sp))
4113 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4114 result = SvIV(*PL_stack_sp);
4115 while (PL_scopestack_ix > oldscopeix) {
4118 leave_scope(oldsaveix);
4123 sortcv_xsub(pTHXo_ SV *a, SV *b)
4126 I32 oldsaveix = PL_savestack_ix;
4127 I32 oldscopeix = PL_scopestack_ix;
4129 CV *cv=(CV*)PL_sortcop;
4137 (void)(*CvXSUB(cv))(aTHXo_ cv);
4138 if (PL_stack_sp != PL_stack_base + 1)
4139 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4140 if (!SvNIOKp(*PL_stack_sp))
4141 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4142 result = SvIV(*PL_stack_sp);
4143 while (PL_scopestack_ix > oldscopeix) {
4146 leave_scope(oldsaveix);
4152 sv_ncmp(pTHXo_ SV *a, SV *b)
4156 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4160 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4164 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4166 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4168 if (PL_amagic_generation) { \
4169 if (SvAMAGIC(left)||SvAMAGIC(right))\
4170 *svp = amagic_call(left, \
4178 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4181 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4186 I32 i = SvIVX(tmpsv);
4196 return sv_ncmp(aTHXo_ a, b);
4200 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4203 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4208 I32 i = SvIVX(tmpsv);
4218 return sv_i_ncmp(aTHXo_ a, b);
4222 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4225 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4230 I32 i = SvIVX(tmpsv);
4240 return sv_cmp(str1, str2);
4244 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4247 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4252 I32 i = SvIVX(tmpsv);
4262 return sv_cmp_locale(str1, str2);
4266 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4268 SV *datasv = FILTER_DATA(idx);
4269 int filter_has_file = IoLINES(datasv);
4270 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4271 SV *filter_state = (SV *)IoTOP_GV(datasv);
4272 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4275 /* I was having segfault trouble under Linux 2.2.5 after a
4276 parse error occured. (Had to hack around it with a test
4277 for PL_error_count == 0.) Solaris doesn't segfault --
4278 not sure where the trouble is yet. XXX */
4280 if (filter_has_file) {
4281 len = FILTER_READ(idx+1, buf_sv, maxlen);
4284 if (filter_sub && len >= 0) {
4295 PUSHs(sv_2mortal(newSViv(maxlen)));
4297 PUSHs(filter_state);
4300 count = call_sv(filter_sub, G_SCALAR);
4316 IoLINES(datasv) = 0;
4317 if (filter_child_proc) {
4318 SvREFCNT_dec(filter_child_proc);
4319 IoFMT_GV(datasv) = Nullgv;
4322 SvREFCNT_dec(filter_state);
4323 IoTOP_GV(datasv) = Nullgv;
4326 SvREFCNT_dec(filter_sub);
4327 IoBOTTOM_GV(datasv) = Nullgv;
4329 filter_del(run_user_filter);
4338 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4340 return sv_cmp_locale(str1, str2);
4344 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4346 return sv_cmp(str1, str2);
4349 #endif /* PERL_OBJECT */