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 RESTORE_NUMERIC_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 = EVAL_INEVAL;
2735 /* set up a scratch pad */
2738 SAVEVPTR(PL_curpad);
2739 SAVESPTR(PL_comppad);
2740 SAVESPTR(PL_comppad_name);
2741 SAVEI32(PL_comppad_name_fill);
2742 SAVEI32(PL_min_intro_pending);
2743 SAVEI32(PL_max_intro_pending);
2746 for (i = cxstack_ix - 1; i >= 0; i--) {
2747 PERL_CONTEXT *cx = &cxstack[i];
2748 if (CxTYPE(cx) == CXt_EVAL)
2750 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2751 caller = cx->blk_sub.cv;
2756 SAVESPTR(PL_compcv);
2757 PL_compcv = (CV*)NEWSV(1104,0);
2758 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2759 CvEVAL_on(PL_compcv);
2761 CvOWNER(PL_compcv) = 0;
2762 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2763 MUTEX_INIT(CvMUTEXP(PL_compcv));
2764 #endif /* USE_THREADS */
2766 PL_comppad = newAV();
2767 av_push(PL_comppad, Nullsv);
2768 PL_curpad = AvARRAY(PL_comppad);
2769 PL_comppad_name = newAV();
2770 PL_comppad_name_fill = 0;
2771 PL_min_intro_pending = 0;
2774 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2775 PL_curpad[0] = (SV*)newAV();
2776 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2777 #endif /* USE_THREADS */
2779 comppadlist = newAV();
2780 AvREAL_off(comppadlist);
2781 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2782 av_store(comppadlist, 1, (SV*)PL_comppad);
2783 CvPADLIST(PL_compcv) = comppadlist;
2786 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2788 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2791 SAVEFREESV(PL_compcv);
2793 /* make sure we compile in the right package */
2795 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2796 SAVESPTR(PL_curstash);
2797 PL_curstash = CopSTASH(PL_curcop);
2799 SAVESPTR(PL_beginav);
2800 PL_beginav = newAV();
2801 SAVEFREESV(PL_beginav);
2802 SAVEI32(PL_error_count);
2804 /* try to compile it */
2806 PL_eval_root = Nullop;
2808 PL_curcop = &PL_compiling;
2809 PL_curcop->cop_arybase = 0;
2810 SvREFCNT_dec(PL_rs);
2811 PL_rs = newSVpvn("\n", 1);
2812 if (saveop && saveop->op_flags & OPf_SPECIAL)
2813 PL_in_eval |= EVAL_KEEPERR;
2816 if (yyparse() || PL_error_count || !PL_eval_root) {
2820 I32 optype = 0; /* Might be reset by POPEVAL. */
2825 op_free(PL_eval_root);
2826 PL_eval_root = Nullop;
2828 SP = PL_stack_base + POPMARK; /* pop original mark */
2830 POPBLOCK(cx,PL_curpm);
2836 if (optype == OP_REQUIRE) {
2837 char* msg = SvPVx(ERRSV, n_a);
2838 DIE(aTHX_ "%sCompilation failed in require",
2839 *msg ? msg : "Unknown error\n");
2842 char* msg = SvPVx(ERRSV, n_a);
2844 POPBLOCK(cx,PL_curpm);
2846 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2847 (*msg ? msg : "Unknown error\n"));
2849 SvREFCNT_dec(PL_rs);
2850 PL_rs = SvREFCNT_inc(PL_nrs);
2852 MUTEX_LOCK(&PL_eval_mutex);
2854 COND_SIGNAL(&PL_eval_cond);
2855 MUTEX_UNLOCK(&PL_eval_mutex);
2856 #endif /* USE_THREADS */
2859 SvREFCNT_dec(PL_rs);
2860 PL_rs = SvREFCNT_inc(PL_nrs);
2861 CopLINE_set(&PL_compiling, 0);
2863 *startop = PL_eval_root;
2864 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2865 CvOUTSIDE(PL_compcv) = Nullcv;
2867 SAVEFREEOP(PL_eval_root);
2869 scalarvoid(PL_eval_root);
2870 else if (gimme & G_ARRAY)
2873 scalar(PL_eval_root);
2875 DEBUG_x(dump_eval());
2877 /* Register with debugger: */
2878 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2879 CV *cv = get_cv("DB::postponed", FALSE);
2883 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2885 call_sv((SV*)cv, G_DISCARD);
2889 /* compiled okay, so do it */
2891 CvDEPTH(PL_compcv) = 1;
2892 SP = PL_stack_base + POPMARK; /* pop original mark */
2893 PL_op = saveop; /* The caller may need it. */
2895 MUTEX_LOCK(&PL_eval_mutex);
2897 COND_SIGNAL(&PL_eval_cond);
2898 MUTEX_UNLOCK(&PL_eval_mutex);
2899 #endif /* USE_THREADS */
2901 RETURNOP(PL_eval_start);
2905 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2907 STRLEN namelen = strlen(name);
2910 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2911 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2912 char *pmc = SvPV_nolen(pmcsv);
2915 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2916 fp = PerlIO_open(name, mode);
2919 if (PerlLIO_stat(name, &pmstat) < 0 ||
2920 pmstat.st_mtime < pmcstat.st_mtime)
2922 fp = PerlIO_open(pmc, mode);
2925 fp = PerlIO_open(name, mode);
2928 SvREFCNT_dec(pmcsv);
2931 fp = PerlIO_open(name, mode);
2939 register PERL_CONTEXT *cx;
2944 SV *namesv = Nullsv;
2946 I32 gimme = G_SCALAR;
2947 PerlIO *tryrsfp = 0;
2949 int filter_has_file = 0;
2950 GV *filter_child_proc = 0;
2951 SV *filter_state = 0;
2956 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2957 UV rev = 0, ver = 0, sver = 0;
2959 U8 *s = (U8*)SvPVX(sv);
2960 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2962 rev = utf8_to_uv(s, &len);
2965 ver = utf8_to_uv(s, &len);
2968 sver = utf8_to_uv(s, &len);
2971 if (PERL_REVISION < rev
2972 || (PERL_REVISION == rev
2973 && (PERL_VERSION < ver
2974 || (PERL_VERSION == ver
2975 && PERL_SUBVERSION < sver))))
2977 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2978 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2979 PERL_VERSION, PERL_SUBVERSION);
2983 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2984 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2985 + ((NV)PERL_SUBVERSION/(NV)1000000)
2986 + 0.00000099 < SvNV(sv))
2990 NV nver = (nrev - rev) * 1000;
2991 UV ver = (UV)(nver + 0.0009);
2992 NV nsver = (nver - ver) * 1000;
2993 UV sver = (UV)(nsver + 0.0009);
2995 /* help out with the "use 5.6" confusion */
2996 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2997 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2998 "this is only v%d.%d.%d, stopped"
2999 " (did you mean v%"UVuf".%"UVuf".0?)",
3000 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3001 PERL_SUBVERSION, rev, ver/100);
3004 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3005 "this is only v%d.%d.%d, stopped",
3006 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3013 name = SvPV(sv, len);
3014 if (!(name && len > 0 && *name))
3015 DIE(aTHX_ "Null filename used");
3016 TAINT_PROPER("require");
3017 if (PL_op->op_type == OP_REQUIRE &&
3018 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3019 *svp != &PL_sv_undef)
3022 /* prepare to compile file */
3024 if (PERL_FILE_IS_ABSOLUTE(name)
3025 || (*name == '.' && (name[1] == '/' ||
3026 (name[1] == '.' && name[2] == '/'))))
3029 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3030 #ifdef MACOS_TRADITIONAL
3031 /* We consider paths of the form :a:b ambiguous and interpret them first
3032 as global then as local
3034 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3043 AV *ar = GvAVn(PL_incgv);
3047 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3050 namesv = NEWSV(806, 0);
3051 for (i = 0; i <= AvFILL(ar); i++) {
3052 SV *dirsv = *av_fetch(ar, i, TRUE);
3058 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3059 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3062 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3063 PTR2UV(SvANY(loader)), name);
3064 tryname = SvPVX(namesv);
3075 count = call_sv(loader, G_ARRAY);
3085 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3089 if (SvTYPE(arg) == SVt_PVGV) {
3090 IO *io = GvIO((GV *)arg);
3095 tryrsfp = IoIFP(io);
3096 if (IoTYPE(io) == '|') {
3097 /* reading from a child process doesn't
3098 nest -- when returning from reading
3099 the inner module, the outer one is
3100 unreadable (closed?) I've tried to
3101 save the gv to manage the lifespan of
3102 the pipe, but this didn't help. XXX */
3103 filter_child_proc = (GV *)arg;
3104 (void)SvREFCNT_inc(filter_child_proc);
3107 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3108 PerlIO_close(IoOFP(io));
3120 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3122 (void)SvREFCNT_inc(filter_sub);
3125 filter_state = SP[i];
3126 (void)SvREFCNT_inc(filter_state);
3130 tryrsfp = PerlIO_open("/dev/null",
3144 filter_has_file = 0;
3145 if (filter_child_proc) {
3146 SvREFCNT_dec(filter_child_proc);
3147 filter_child_proc = 0;
3150 SvREFCNT_dec(filter_state);
3154 SvREFCNT_dec(filter_sub);
3159 char *dir = SvPVx(dirsv, n_a);
3160 #ifdef MACOS_TRADITIONAL
3162 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3166 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3168 sv_setpv(namesv, unixdir);
3169 sv_catpv(namesv, unixname);
3171 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3174 TAINT_PROPER("require");
3175 tryname = SvPVX(namesv);
3176 #ifdef MACOS_TRADITIONAL
3178 /* Convert slashes in the name part, but not the directory part, to colons */
3180 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3184 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3186 if (tryname[0] == '.' && tryname[1] == '/')
3194 SAVECOPFILE_FREE(&PL_compiling);
3195 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3196 SvREFCNT_dec(namesv);
3198 if (PL_op->op_type == OP_REQUIRE) {
3199 char *msgstr = name;
3200 if (namesv) { /* did we lookup @INC? */
3201 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3202 SV *dirmsgsv = NEWSV(0, 0);
3203 AV *ar = GvAVn(PL_incgv);
3205 sv_catpvn(msg, " in @INC", 8);
3206 if (instr(SvPVX(msg), ".h "))
3207 sv_catpv(msg, " (change .h to .ph maybe?)");
3208 if (instr(SvPVX(msg), ".ph "))
3209 sv_catpv(msg, " (did you run h2ph?)");
3210 sv_catpv(msg, " (@INC contains:");
3211 for (i = 0; i <= AvFILL(ar); i++) {
3212 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3213 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3214 sv_catsv(msg, dirmsgsv);
3216 sv_catpvn(msg, ")", 1);
3217 SvREFCNT_dec(dirmsgsv);
3218 msgstr = SvPV_nolen(msg);
3220 DIE(aTHX_ "Can't locate %s", msgstr);
3226 SETERRNO(0, SS$_NORMAL);
3228 /* Assume success here to prevent recursive requirement. */
3229 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3230 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3234 lex_start(sv_2mortal(newSVpvn("",0)));
3235 SAVEGENERICSV(PL_rsfp_filters);
3236 PL_rsfp_filters = Nullav;
3241 SAVESPTR(PL_compiling.cop_warnings);
3242 if (PL_dowarn & G_WARN_ALL_ON)
3243 PL_compiling.cop_warnings = pWARN_ALL ;
3244 else if (PL_dowarn & G_WARN_ALL_OFF)
3245 PL_compiling.cop_warnings = pWARN_NONE ;
3247 PL_compiling.cop_warnings = pWARN_STD ;
3249 if (filter_sub || filter_child_proc) {
3250 SV *datasv = filter_add(run_user_filter, Nullsv);
3251 IoLINES(datasv) = filter_has_file;
3252 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3253 IoTOP_GV(datasv) = (GV *)filter_state;
3254 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3257 /* switch to eval mode */
3258 push_return(PL_op->op_next);
3259 PUSHBLOCK(cx, CXt_EVAL, SP);
3260 PUSHEVAL(cx, name, Nullgv);
3262 SAVECOPLINE(&PL_compiling);
3263 CopLINE_set(&PL_compiling, 0);
3267 MUTEX_LOCK(&PL_eval_mutex);
3268 if (PL_eval_owner && PL_eval_owner != thr)
3269 while (PL_eval_owner)
3270 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3271 PL_eval_owner = thr;
3272 MUTEX_UNLOCK(&PL_eval_mutex);
3273 #endif /* USE_THREADS */
3274 return DOCATCH(doeval(G_SCALAR, NULL));
3279 return pp_require();
3285 register PERL_CONTEXT *cx;
3287 I32 gimme = GIMME_V, was = PL_sub_generation;
3288 char tbuf[TYPE_DIGITS(long) + 12];
3289 char *tmpbuf = tbuf;
3294 if (!SvPV(sv,len) || !len)
3296 TAINT_PROPER("eval");
3302 /* switch to eval mode */
3304 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3305 SV *sv = sv_newmortal();
3306 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3307 (unsigned long)++PL_evalseq,
3308 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3312 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3313 SAVECOPFILE_FREE(&PL_compiling);
3314 CopFILE_set(&PL_compiling, tmpbuf+2);
3315 SAVECOPLINE(&PL_compiling);
3316 CopLINE_set(&PL_compiling, 1);
3317 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3318 deleting the eval's FILEGV from the stash before gv_check() runs
3319 (i.e. before run-time proper). To work around the coredump that
3320 ensues, we always turn GvMULTI_on for any globals that were
3321 introduced within evals. See force_ident(). GSAR 96-10-12 */
3322 safestr = savepv(tmpbuf);
3323 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3325 PL_hints = PL_op->op_targ;
3326 SAVESPTR(PL_compiling.cop_warnings);
3327 if (specialWARN(PL_curcop->cop_warnings))
3328 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3330 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3331 SAVEFREESV(PL_compiling.cop_warnings);
3334 push_return(PL_op->op_next);
3335 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3336 PUSHEVAL(cx, 0, Nullgv);
3338 /* prepare to compile string */
3340 if (PERLDB_LINE && PL_curstash != PL_debstash)
3341 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3344 MUTEX_LOCK(&PL_eval_mutex);
3345 if (PL_eval_owner && PL_eval_owner != thr)
3346 while (PL_eval_owner)
3347 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3348 PL_eval_owner = thr;
3349 MUTEX_UNLOCK(&PL_eval_mutex);
3350 #endif /* USE_THREADS */
3351 ret = doeval(gimme, NULL);
3352 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3353 && ret != PL_op->op_next) { /* Successive compilation. */
3354 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3356 return DOCATCH(ret);
3366 register PERL_CONTEXT *cx;
3368 U8 save_flags = PL_op -> op_flags;
3373 retop = pop_return();
3376 if (gimme == G_VOID)
3378 else if (gimme == G_SCALAR) {
3381 if (SvFLAGS(TOPs) & SVs_TEMP)
3384 *MARK = sv_mortalcopy(TOPs);
3388 *MARK = &PL_sv_undef;
3393 /* in case LEAVE wipes old return values */
3394 for (mark = newsp + 1; mark <= SP; mark++) {
3395 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3396 *mark = sv_mortalcopy(*mark);
3397 TAINT_NOT; /* Each item is independent */
3401 PL_curpm = newpm; /* Don't pop $1 et al till now */
3403 if (AvFILLp(PL_comppad_name) >= 0)
3407 assert(CvDEPTH(PL_compcv) == 1);
3409 CvDEPTH(PL_compcv) = 0;
3412 if (optype == OP_REQUIRE &&
3413 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3415 /* Unassume the success we assumed earlier. */
3416 SV *nsv = cx->blk_eval.old_namesv;
3417 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3418 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3419 /* die_where() did LEAVE, or we won't be here */
3423 if (!(save_flags & OPf_SPECIAL))
3433 register PERL_CONTEXT *cx;
3434 I32 gimme = GIMME_V;
3439 push_return(cLOGOP->op_other->op_next);
3440 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3442 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3444 PL_in_eval = EVAL_INEVAL;
3447 return DOCATCH(PL_op->op_next);
3457 register PERL_CONTEXT *cx;
3465 if (gimme == G_VOID)
3467 else if (gimme == G_SCALAR) {
3470 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3473 *MARK = sv_mortalcopy(TOPs);
3477 *MARK = &PL_sv_undef;
3482 /* in case LEAVE wipes old return values */
3483 for (mark = newsp + 1; mark <= SP; mark++) {
3484 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3485 *mark = sv_mortalcopy(*mark);
3486 TAINT_NOT; /* Each item is independent */
3490 PL_curpm = newpm; /* Don't pop $1 et al till now */
3498 S_doparseform(pTHX_ SV *sv)
3501 register char *s = SvPV_force(sv, len);
3502 register char *send = s + len;
3503 register char *base;
3504 register I32 skipspaces = 0;
3507 bool postspace = FALSE;
3515 Perl_croak(aTHX_ "Null picture in formline");
3517 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3522 *fpc++ = FF_LINEMARK;
3523 noblank = repeat = FALSE;
3541 case ' ': case '\t':
3552 *fpc++ = FF_LITERAL;
3560 *fpc++ = skipspaces;
3564 *fpc++ = FF_NEWLINE;
3568 arg = fpc - linepc + 1;
3575 *fpc++ = FF_LINEMARK;
3576 noblank = repeat = FALSE;
3585 ischop = s[-1] == '^';
3591 arg = (s - base) - 1;
3593 *fpc++ = FF_LITERAL;
3602 *fpc++ = FF_LINEGLOB;
3604 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3605 arg = ischop ? 512 : 0;
3615 arg |= 256 + (s - f);
3617 *fpc++ = s - base; /* fieldsize for FETCH */
3618 *fpc++ = FF_DECIMAL;
3623 bool ismore = FALSE;
3626 while (*++s == '>') ;
3627 prespace = FF_SPACE;
3629 else if (*s == '|') {
3630 while (*++s == '|') ;
3631 prespace = FF_HALFSPACE;
3636 while (*++s == '<') ;
3639 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3643 *fpc++ = s - base; /* fieldsize for FETCH */
3645 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3663 { /* need to jump to the next word */
3665 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3666 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3667 s = SvPVX(sv) + SvCUR(sv) + z;
3669 Copy(fops, s, arg, U16);
3671 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3676 * The rest of this file was derived from source code contributed
3679 * NOTE: this code was derived from Tom Horsley's qsort replacement
3680 * and should not be confused with the original code.
3683 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3685 Permission granted to distribute under the same terms as perl which are
3688 This program is free software; you can redistribute it and/or modify
3689 it under the terms of either:
3691 a) the GNU General Public License as published by the Free
3692 Software Foundation; either version 1, or (at your option) any
3695 b) the "Artistic License" which comes with this Kit.
3697 Details on the perl license can be found in the perl source code which
3698 may be located via the www.perl.com web page.
3700 This is the most wonderfulest possible qsort I can come up with (and
3701 still be mostly portable) My (limited) tests indicate it consistently
3702 does about 20% fewer calls to compare than does the qsort in the Visual
3703 C++ library, other vendors may vary.
3705 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3706 others I invented myself (or more likely re-invented since they seemed
3707 pretty obvious once I watched the algorithm operate for a while).
3709 Most of this code was written while watching the Marlins sweep the Giants
3710 in the 1997 National League Playoffs - no Braves fans allowed to use this
3711 code (just kidding :-).
3713 I realize that if I wanted to be true to the perl tradition, the only
3714 comment in this file would be something like:
3716 ...they shuffled back towards the rear of the line. 'No, not at the
3717 rear!' the slave-driver shouted. 'Three files up. And stay there...
3719 However, I really needed to violate that tradition just so I could keep
3720 track of what happens myself, not to mention some poor fool trying to
3721 understand this years from now :-).
3724 /* ********************************************************** Configuration */
3726 #ifndef QSORT_ORDER_GUESS
3727 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3730 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3731 future processing - a good max upper bound is log base 2 of memory size
3732 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3733 safely be smaller than that since the program is taking up some space and
3734 most operating systems only let you grab some subset of contiguous
3735 memory (not to mention that you are normally sorting data larger than
3736 1 byte element size :-).
3738 #ifndef QSORT_MAX_STACK
3739 #define QSORT_MAX_STACK 32
3742 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3743 Anything bigger and we use qsort. If you make this too small, the qsort
3744 will probably break (or become less efficient), because it doesn't expect
3745 the middle element of a partition to be the same as the right or left -
3746 you have been warned).
3748 #ifndef QSORT_BREAK_EVEN
3749 #define QSORT_BREAK_EVEN 6
3752 /* ************************************************************* Data Types */
3754 /* hold left and right index values of a partition waiting to be sorted (the
3755 partition includes both left and right - right is NOT one past the end or
3756 anything like that).
3758 struct partition_stack_entry {
3761 #ifdef QSORT_ORDER_GUESS
3762 int qsort_break_even;
3766 /* ******************************************************* Shorthand Macros */
3768 /* Note that these macros will be used from inside the qsort function where
3769 we happen to know that the variable 'elt_size' contains the size of an
3770 array element and the variable 'temp' points to enough space to hold a
3771 temp element and the variable 'array' points to the array being sorted
3772 and 'compare' is the pointer to the compare routine.
3774 Also note that there are very many highly architecture specific ways
3775 these might be sped up, but this is simply the most generally portable
3776 code I could think of.
3779 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3781 #define qsort_cmp(elt1, elt2) \
3782 ((*compare)(aTHXo_ array[elt1], array[elt2]))
3784 #ifdef QSORT_ORDER_GUESS
3785 #define QSORT_NOTICE_SWAP swapped++;
3787 #define QSORT_NOTICE_SWAP
3790 /* swaps contents of array elements elt1, elt2.
3792 #define qsort_swap(elt1, elt2) \
3795 temp = array[elt1]; \
3796 array[elt1] = array[elt2]; \
3797 array[elt2] = temp; \
3800 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3801 elt3 and elt3 gets elt1.
3803 #define qsort_rotate(elt1, elt2, elt3) \
3806 temp = array[elt1]; \
3807 array[elt1] = array[elt2]; \
3808 array[elt2] = array[elt3]; \
3809 array[elt3] = temp; \
3812 /* ************************************************************ Debug stuff */
3819 return; /* good place to set a breakpoint */
3822 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3825 doqsort_all_asserts(
3829 int (*compare)(const void * elt1, const void * elt2),
3830 int pc_left, int pc_right, int u_left, int u_right)
3834 qsort_assert(pc_left <= pc_right);
3835 qsort_assert(u_right < pc_left);
3836 qsort_assert(pc_right < u_left);
3837 for (i = u_right + 1; i < pc_left; ++i) {
3838 qsort_assert(qsort_cmp(i, pc_left) < 0);
3840 for (i = pc_left; i < pc_right; ++i) {
3841 qsort_assert(qsort_cmp(i, pc_right) == 0);
3843 for (i = pc_right + 1; i < u_left; ++i) {
3844 qsort_assert(qsort_cmp(pc_right, i) < 0);
3848 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3849 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3850 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3854 #define qsort_assert(t) ((void)0)
3856 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3860 /* ****************************************************************** qsort */
3863 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3867 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3868 int next_stack_entry = 0;
3872 #ifdef QSORT_ORDER_GUESS
3873 int qsort_break_even;
3877 /* Make sure we actually have work to do.
3879 if (num_elts <= 1) {
3883 /* Setup the initial partition definition and fall into the sorting loop
3886 part_right = (int)(num_elts - 1);
3887 #ifdef QSORT_ORDER_GUESS
3888 qsort_break_even = QSORT_BREAK_EVEN;
3890 #define qsort_break_even QSORT_BREAK_EVEN
3893 if ((part_right - part_left) >= qsort_break_even) {
3894 /* OK, this is gonna get hairy, so lets try to document all the
3895 concepts and abbreviations and variables and what they keep
3898 pc: pivot chunk - the set of array elements we accumulate in the
3899 middle of the partition, all equal in value to the original
3900 pivot element selected. The pc is defined by:
3902 pc_left - the leftmost array index of the pc
3903 pc_right - the rightmost array index of the pc
3905 we start with pc_left == pc_right and only one element
3906 in the pivot chunk (but it can grow during the scan).
3908 u: uncompared elements - the set of elements in the partition
3909 we have not yet compared to the pivot value. There are two
3910 uncompared sets during the scan - one to the left of the pc
3911 and one to the right.
3913 u_right - the rightmost index of the left side's uncompared set
3914 u_left - the leftmost index of the right side's uncompared set
3916 The leftmost index of the left sides's uncompared set
3917 doesn't need its own variable because it is always defined
3918 by the leftmost edge of the whole partition (part_left). The
3919 same goes for the rightmost edge of the right partition
3922 We know there are no uncompared elements on the left once we
3923 get u_right < part_left and no uncompared elements on the
3924 right once u_left > part_right. When both these conditions
3925 are met, we have completed the scan of the partition.
3927 Any elements which are between the pivot chunk and the
3928 uncompared elements should be less than the pivot value on
3929 the left side and greater than the pivot value on the right
3930 side (in fact, the goal of the whole algorithm is to arrange
3931 for that to be true and make the groups of less-than and
3932 greater-then elements into new partitions to sort again).
3934 As you marvel at the complexity of the code and wonder why it
3935 has to be so confusing. Consider some of the things this level
3936 of confusion brings:
3938 Once I do a compare, I squeeze every ounce of juice out of it. I
3939 never do compare calls I don't have to do, and I certainly never
3942 I also never swap any elements unless I can prove there is a
3943 good reason. Many sort algorithms will swap a known value with
3944 an uncompared value just to get things in the right place (or
3945 avoid complexity :-), but that uncompared value, once it gets
3946 compared, may then have to be swapped again. A lot of the
3947 complexity of this code is due to the fact that it never swaps
3948 anything except compared values, and it only swaps them when the
3949 compare shows they are out of position.
3951 int pc_left, pc_right;
3952 int u_right, u_left;
3956 pc_left = ((part_left + part_right) / 2);
3958 u_right = pc_left - 1;
3959 u_left = pc_right + 1;
3961 /* Qsort works best when the pivot value is also the median value
3962 in the partition (unfortunately you can't find the median value
3963 without first sorting :-), so to give the algorithm a helping
3964 hand, we pick 3 elements and sort them and use the median value
3965 of that tiny set as the pivot value.
3967 Some versions of qsort like to use the left middle and right as
3968 the 3 elements to sort so they can insure the ends of the
3969 partition will contain values which will stop the scan in the
3970 compare loop, but when you have to call an arbitrarily complex
3971 routine to do a compare, its really better to just keep track of
3972 array index values to know when you hit the edge of the
3973 partition and avoid the extra compare. An even better reason to
3974 avoid using a compare call is the fact that you can drop off the
3975 edge of the array if someone foolishly provides you with an
3976 unstable compare function that doesn't always provide consistent
3979 So, since it is simpler for us to compare the three adjacent
3980 elements in the middle of the partition, those are the ones we
3981 pick here (conveniently pointed at by u_right, pc_left, and
3982 u_left). The values of the left, center, and right elements
3983 are refered to as l c and r in the following comments.
3986 #ifdef QSORT_ORDER_GUESS
3989 s = qsort_cmp(u_right, pc_left);
3992 s = qsort_cmp(pc_left, u_left);
3993 /* if l < c, c < r - already in order - nothing to do */
3995 /* l < c, c == r - already in order, pc grows */
3997 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3999 /* l < c, c > r - need to know more */
4000 s = qsort_cmp(u_right, u_left);
4002 /* l < c, c > r, l < r - swap c & r to get ordered */
4003 qsort_swap(pc_left, u_left);
4004 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4005 } else if (s == 0) {
4006 /* l < c, c > r, l == r - swap c&r, grow pc */
4007 qsort_swap(pc_left, u_left);
4009 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4011 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
4012 qsort_rotate(pc_left, u_right, u_left);
4013 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4016 } else if (s == 0) {
4018 s = qsort_cmp(pc_left, u_left);
4020 /* l == c, c < r - already in order, grow pc */
4022 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4023 } else if (s == 0) {
4024 /* l == c, c == r - already in order, grow pc both ways */
4027 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4029 /* l == c, c > r - swap l & r, grow pc */
4030 qsort_swap(u_right, u_left);
4032 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4036 s = qsort_cmp(pc_left, u_left);
4038 /* l > c, c < r - need to know more */
4039 s = qsort_cmp(u_right, u_left);
4041 /* l > c, c < r, l < r - swap l & c to get ordered */
4042 qsort_swap(u_right, pc_left);
4043 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4044 } else if (s == 0) {
4045 /* l > c, c < r, l == r - swap l & c, grow pc */
4046 qsort_swap(u_right, pc_left);
4048 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4050 /* l > c, c < r, l > r - rotate lcr into crl to order */
4051 qsort_rotate(u_right, pc_left, u_left);
4052 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4054 } else if (s == 0) {
4055 /* l > c, c == r - swap ends, grow pc */
4056 qsort_swap(u_right, u_left);
4058 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4060 /* l > c, c > r - swap ends to get in order */
4061 qsort_swap(u_right, u_left);
4062 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4065 /* We now know the 3 middle elements have been compared and
4066 arranged in the desired order, so we can shrink the uncompared
4071 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4073 /* The above massive nested if was the simple part :-). We now have
4074 the middle 3 elements ordered and we need to scan through the
4075 uncompared sets on either side, swapping elements that are on
4076 the wrong side or simply shuffling equal elements around to get
4077 all equal elements into the pivot chunk.
4081 int still_work_on_left;
4082 int still_work_on_right;
4084 /* Scan the uncompared values on the left. If I find a value
4085 equal to the pivot value, move it over so it is adjacent to
4086 the pivot chunk and expand the pivot chunk. If I find a value
4087 less than the pivot value, then just leave it - its already
4088 on the correct side of the partition. If I find a greater
4089 value, then stop the scan.
4091 while ((still_work_on_left = (u_right >= part_left))) {
4092 s = qsort_cmp(u_right, pc_left);
4095 } else if (s == 0) {
4097 if (pc_left != u_right) {
4098 qsort_swap(u_right, pc_left);
4104 qsort_assert(u_right < pc_left);
4105 qsort_assert(pc_left <= pc_right);
4106 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4107 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4110 /* Do a mirror image scan of uncompared values on the right
4112 while ((still_work_on_right = (u_left <= part_right))) {
4113 s = qsort_cmp(pc_right, u_left);
4116 } else if (s == 0) {
4118 if (pc_right != u_left) {
4119 qsort_swap(pc_right, u_left);
4125 qsort_assert(u_left > pc_right);
4126 qsort_assert(pc_left <= pc_right);
4127 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4128 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4131 if (still_work_on_left) {
4132 /* I know I have a value on the left side which needs to be
4133 on the right side, but I need to know more to decide
4134 exactly the best thing to do with it.
4136 if (still_work_on_right) {
4137 /* I know I have values on both side which are out of
4138 position. This is a big win because I kill two birds
4139 with one swap (so to speak). I can advance the
4140 uncompared pointers on both sides after swapping both
4141 of them into the right place.
4143 qsort_swap(u_right, u_left);
4146 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4148 /* I have an out of position value on the left, but the
4149 right is fully scanned, so I "slide" the pivot chunk
4150 and any less-than values left one to make room for the
4151 greater value over on the right. If the out of position
4152 value is immediately adjacent to the pivot chunk (there
4153 are no less-than values), I can do that with a swap,
4154 otherwise, I have to rotate one of the less than values
4155 into the former position of the out of position value
4156 and the right end of the pivot chunk into the left end
4160 if (pc_left == u_right) {
4161 qsort_swap(u_right, pc_right);
4162 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4164 qsort_rotate(u_right, pc_left, pc_right);
4165 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4170 } else if (still_work_on_right) {
4171 /* Mirror image of complex case above: I have an out of
4172 position value on the right, but the left is fully
4173 scanned, so I need to shuffle things around to make room
4174 for the right value on the left.
4177 if (pc_right == u_left) {
4178 qsort_swap(u_left, pc_left);
4179 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4181 qsort_rotate(pc_right, pc_left, u_left);
4182 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4187 /* No more scanning required on either side of partition,
4188 break out of loop and figure out next set of partitions
4194 /* The elements in the pivot chunk are now in the right place. They
4195 will never move or be compared again. All I have to do is decide
4196 what to do with the stuff to the left and right of the pivot
4199 Notes on the QSORT_ORDER_GUESS ifdef code:
4201 1. If I just built these partitions without swapping any (or
4202 very many) elements, there is a chance that the elements are
4203 already ordered properly (being properly ordered will
4204 certainly result in no swapping, but the converse can't be
4207 2. A (properly written) insertion sort will run faster on
4208 already ordered data than qsort will.
4210 3. Perhaps there is some way to make a good guess about
4211 switching to an insertion sort earlier than partition size 6
4212 (for instance - we could save the partition size on the stack
4213 and increase the size each time we find we didn't swap, thus
4214 switching to insertion sort earlier for partitions with a
4215 history of not swapping).
4217 4. Naturally, if I just switch right away, it will make
4218 artificial benchmarks with pure ascending (or descending)
4219 data look really good, but is that a good reason in general?
4223 #ifdef QSORT_ORDER_GUESS
4225 #if QSORT_ORDER_GUESS == 1
4226 qsort_break_even = (part_right - part_left) + 1;
4228 #if QSORT_ORDER_GUESS == 2
4229 qsort_break_even *= 2;
4231 #if QSORT_ORDER_GUESS == 3
4232 int prev_break = qsort_break_even;
4233 qsort_break_even *= qsort_break_even;
4234 if (qsort_break_even < prev_break) {
4235 qsort_break_even = (part_right - part_left) + 1;
4239 qsort_break_even = QSORT_BREAK_EVEN;
4243 if (part_left < pc_left) {
4244 /* There are elements on the left which need more processing.
4245 Check the right as well before deciding what to do.
4247 if (pc_right < part_right) {
4248 /* We have two partitions to be sorted. Stack the biggest one
4249 and process the smallest one on the next iteration. This
4250 minimizes the stack height by insuring that any additional
4251 stack entries must come from the smallest partition which
4252 (because it is smallest) will have the fewest
4253 opportunities to generate additional stack entries.
4255 if ((part_right - pc_right) > (pc_left - part_left)) {
4256 /* stack the right partition, process the left */
4257 partition_stack[next_stack_entry].left = pc_right + 1;
4258 partition_stack[next_stack_entry].right = part_right;
4259 #ifdef QSORT_ORDER_GUESS
4260 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4262 part_right = pc_left - 1;
4264 /* stack the left partition, process the right */
4265 partition_stack[next_stack_entry].left = part_left;
4266 partition_stack[next_stack_entry].right = pc_left - 1;
4267 #ifdef QSORT_ORDER_GUESS
4268 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4270 part_left = pc_right + 1;
4272 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4275 /* The elements on the left are the only remaining elements
4276 that need sorting, arrange for them to be processed as the
4279 part_right = pc_left - 1;
4281 } else if (pc_right < part_right) {
4282 /* There is only one chunk on the right to be sorted, make it
4283 the new partition and loop back around.
4285 part_left = pc_right + 1;
4287 /* This whole partition wound up in the pivot chunk, so
4288 we need to get a new partition off the stack.
4290 if (next_stack_entry == 0) {
4291 /* the stack is empty - we are done */
4295 part_left = partition_stack[next_stack_entry].left;
4296 part_right = partition_stack[next_stack_entry].right;
4297 #ifdef QSORT_ORDER_GUESS
4298 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4302 /* This partition is too small to fool with qsort complexity, just
4303 do an ordinary insertion sort to minimize overhead.
4306 /* Assume 1st element is in right place already, and start checking
4307 at 2nd element to see where it should be inserted.
4309 for (i = part_left + 1; i <= part_right; ++i) {
4311 /* Scan (backwards - just in case 'i' is already in right place)
4312 through the elements already sorted to see if the ith element
4313 belongs ahead of one of them.
4315 for (j = i - 1; j >= part_left; --j) {
4316 if (qsort_cmp(i, j) >= 0) {
4317 /* i belongs right after j
4324 /* Looks like we really need to move some things
4328 for (k = i - 1; k >= j; --k)
4329 array[k + 1] = array[k];
4334 /* That partition is now sorted, grab the next one, or get out
4335 of the loop if there aren't any more.
4338 if (next_stack_entry == 0) {
4339 /* the stack is empty - we are done */
4343 part_left = partition_stack[next_stack_entry].left;
4344 part_right = partition_stack[next_stack_entry].right;
4345 #ifdef QSORT_ORDER_GUESS
4346 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4351 /* Believe it or not, the array is sorted at this point! */
4363 sortcv(pTHXo_ SV *a, SV *b)
4366 I32 oldsaveix = PL_savestack_ix;
4367 I32 oldscopeix = PL_scopestack_ix;
4369 GvSV(PL_firstgv) = a;
4370 GvSV(PL_secondgv) = b;
4371 PL_stack_sp = PL_stack_base;
4374 if (PL_stack_sp != PL_stack_base + 1)
4375 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4376 if (!SvNIOKp(*PL_stack_sp))
4377 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4378 result = SvIV(*PL_stack_sp);
4379 while (PL_scopestack_ix > oldscopeix) {
4382 leave_scope(oldsaveix);
4387 sortcv_stacked(pTHXo_ SV *a, SV *b)
4390 I32 oldsaveix = PL_savestack_ix;
4391 I32 oldscopeix = PL_scopestack_ix;
4396 av = (AV*)PL_curpad[0];
4398 av = GvAV(PL_defgv);
4401 if (AvMAX(av) < 1) {
4402 SV** ary = AvALLOC(av);
4403 if (AvARRAY(av) != ary) {
4404 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4405 SvPVX(av) = (char*)ary;
4407 if (AvMAX(av) < 1) {
4410 SvPVX(av) = (char*)ary;
4417 PL_stack_sp = PL_stack_base;
4420 if (PL_stack_sp != PL_stack_base + 1)
4421 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4422 if (!SvNIOKp(*PL_stack_sp))
4423 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4424 result = SvIV(*PL_stack_sp);
4425 while (PL_scopestack_ix > oldscopeix) {
4428 leave_scope(oldsaveix);
4433 sortcv_xsub(pTHXo_ SV *a, SV *b)
4436 I32 oldsaveix = PL_savestack_ix;
4437 I32 oldscopeix = PL_scopestack_ix;
4439 CV *cv=(CV*)PL_sortcop;
4447 (void)(*CvXSUB(cv))(aTHXo_ cv);
4448 if (PL_stack_sp != PL_stack_base + 1)
4449 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4450 if (!SvNIOKp(*PL_stack_sp))
4451 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4452 result = SvIV(*PL_stack_sp);
4453 while (PL_scopestack_ix > oldscopeix) {
4456 leave_scope(oldsaveix);
4462 sv_ncmp(pTHXo_ SV *a, SV *b)
4466 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4470 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4474 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4476 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4478 if (PL_amagic_generation) { \
4479 if (SvAMAGIC(left)||SvAMAGIC(right))\
4480 *svp = amagic_call(left, \
4488 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4491 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4496 I32 i = SvIVX(tmpsv);
4506 return sv_ncmp(aTHXo_ a, b);
4510 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4513 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4518 I32 i = SvIVX(tmpsv);
4528 return sv_i_ncmp(aTHXo_ a, b);
4532 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4535 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4540 I32 i = SvIVX(tmpsv);
4550 return sv_cmp(str1, str2);
4554 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4557 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4562 I32 i = SvIVX(tmpsv);
4572 return sv_cmp_locale(str1, str2);
4576 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4578 SV *datasv = FILTER_DATA(idx);
4579 int filter_has_file = IoLINES(datasv);
4580 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4581 SV *filter_state = (SV *)IoTOP_GV(datasv);
4582 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4585 /* I was having segfault trouble under Linux 2.2.5 after a
4586 parse error occured. (Had to hack around it with a test
4587 for PL_error_count == 0.) Solaris doesn't segfault --
4588 not sure where the trouble is yet. XXX */
4590 if (filter_has_file) {
4591 len = FILTER_READ(idx+1, buf_sv, maxlen);
4594 if (filter_sub && len >= 0) {
4605 PUSHs(sv_2mortal(newSViv(maxlen)));
4607 PUSHs(filter_state);
4610 count = call_sv(filter_sub, G_SCALAR);
4626 IoLINES(datasv) = 0;
4627 if (filter_child_proc) {
4628 SvREFCNT_dec(filter_child_proc);
4629 IoFMT_GV(datasv) = Nullgv;
4632 SvREFCNT_dec(filter_state);
4633 IoTOP_GV(datasv) = Nullgv;
4636 SvREFCNT_dec(filter_sub);
4637 IoBOTTOM_GV(datasv) = Nullgv;
4639 filter_del(run_user_filter);
4648 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4650 return sv_cmp_locale(str1, str2);
4654 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4656 return sv_cmp(str1, str2);
4659 #endif /* PERL_OBJECT */