3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 sortcv(pTHXo_ SV *a, SV *b);
30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
44 #define sv_cmp_static Perl_sv_cmp
45 #define sv_cmp_locale_static Perl_sv_cmp_locale
54 cxix = dopoptosub(cxstack_ix);
58 switch (cxstack[cxix].blk_gimme) {
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
88 MAGIC *mg = Null(MAGIC*);
92 SV *sv = SvRV(tmpstr);
94 mg = mg_find(sv, 'r');
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
102 t = SvPV(tmpstr, len);
104 /* Check against the last compiled regexp. */
105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
118 pm->op_pmdynflags |= PMdf_DYN_UTF8;
120 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
121 if (pm->op_pmdynflags & PMdf_UTF8)
122 t = (char*)bytes_to_utf8((U8*)t, &len);
124 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
125 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
127 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
128 inside tie/overload accessors. */
132 #ifndef INCOMPLETE_TAINTS
135 pm->op_pmdynflags |= PMdf_TAINTED;
137 pm->op_pmdynflags &= ~PMdf_TAINTED;
141 if (!pm->op_pmregexp->prelen && PL_curpm)
143 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
144 pm->op_pmflags |= PMf_WHITE;
146 /* XXX runtime compiled output needs to move to the pad */
147 if (pm->op_pmflags & PMf_KEEP) {
148 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
149 #if !defined(USE_ITHREADS) && !defined(USE_THREADS)
150 /* XXX can't change the optree at runtime either */
151 cLOGOP->op_first->op_next = PL_op->op_next;
160 register PMOP *pm = (PMOP*) cLOGOP->op_other;
161 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
162 register SV *dstr = cx->sb_dstr;
163 register char *s = cx->sb_s;
164 register char *m = cx->sb_m;
165 char *orig = cx->sb_orig;
166 register REGEXP *rx = cx->sb_rx;
168 rxres_restore(&cx->sb_rxres, rx);
170 if (cx->sb_iters++) {
171 if (cx->sb_iters > cx->sb_maxiters)
172 DIE(aTHX_ "Substitution loop");
174 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
175 cx->sb_rxtainted |= 2;
176 sv_catsv(dstr, POPs);
179 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
180 s == m, cx->sb_targ, NULL,
181 ((cx->sb_rflags & REXEC_COPY_STR)
182 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
183 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
185 SV *targ = cx->sb_targ;
187 sv_catpvn(dstr, s, cx->sb_strend - s);
188 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
190 (void)SvOOK_off(targ);
191 Safefree(SvPVX(targ));
192 SvPVX(targ) = SvPVX(dstr);
193 SvCUR_set(targ, SvCUR(dstr));
194 SvLEN_set(targ, SvLEN(dstr));
200 TAINT_IF(cx->sb_rxtainted & 1);
201 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
203 (void)SvPOK_only_UTF8(targ);
204 TAINT_IF(cx->sb_rxtainted);
208 LEAVE_SCOPE(cx->sb_oldsave);
210 RETURNOP(pm->op_next);
213 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
216 cx->sb_orig = orig = rx->subbeg;
218 cx->sb_strend = s + (cx->sb_strend - m);
220 cx->sb_m = m = rx->startp[0] + orig;
222 sv_catpvn(dstr, s, m-s);
223 cx->sb_s = rx->endp[0] + orig;
224 { /* Update the pos() information. */
225 SV *sv = cx->sb_targ;
228 if (SvTYPE(sv) < SVt_PVMG)
229 (void)SvUPGRADE(sv, SVt_PVMG);
230 if (!(mg = mg_find(sv, 'g'))) {
231 sv_magic(sv, Nullsv, 'g', Nullch, 0);
232 mg = mg_find(sv, 'g');
239 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
240 rxres_save(&cx->sb_rxres, rx);
241 RETURNOP(pm->op_pmreplstart);
245 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
250 if (!p || p[1] < rx->nparens) {
251 i = 6 + rx->nparens * 2;
259 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
260 RX_MATCH_COPIED_off(rx);
264 *p++ = PTR2UV(rx->subbeg);
265 *p++ = (UV)rx->sublen;
266 for (i = 0; i <= rx->nparens; ++i) {
267 *p++ = (UV)rx->startp[i];
268 *p++ = (UV)rx->endp[i];
273 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
278 if (RX_MATCH_COPIED(rx))
279 Safefree(rx->subbeg);
280 RX_MATCH_COPIED_set(rx, *p);
285 rx->subbeg = INT2PTR(char*,*p++);
286 rx->sublen = (I32)(*p++);
287 for (i = 0; i <= rx->nparens; ++i) {
288 rx->startp[i] = (I32)(*p++);
289 rx->endp[i] = (I32)(*p++);
294 Perl_rxres_free(pTHX_ void **rsp)
299 Safefree(INT2PTR(char*,*p));
307 dSP; dMARK; dORIGMARK;
308 register SV *tmpForm = *++MARK;
320 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
326 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
327 bool item_is_utf = FALSE;
329 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
330 if (SvREADONLY(tmpForm)) {
331 SvREADONLY_off(tmpForm);
332 doparseform(tmpForm);
333 SvREADONLY_on(tmpForm);
336 doparseform(tmpForm);
339 SvPV_force(PL_formtarget, len);
340 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
342 f = SvPV(tmpForm, len);
343 /* need to jump to the next word */
344 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
353 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
354 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
355 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
356 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
357 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
359 case FF_CHECKNL: name = "CHECKNL"; break;
360 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
361 case FF_SPACE: name = "SPACE"; break;
362 case FF_HALFSPACE: name = "HALFSPACE"; break;
363 case FF_ITEM: name = "ITEM"; break;
364 case FF_CHOP: name = "CHOP"; break;
365 case FF_LINEGLOB: name = "LINEGLOB"; break;
366 case FF_NEWLINE: name = "NEWLINE"; break;
367 case FF_MORE: name = "MORE"; break;
368 case FF_LINEMARK: name = "LINEMARK"; break;
369 case FF_END: name = "END"; break;
370 case FF_0DECIMAL: name = "0DECIMAL"; break;
373 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
375 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
403 if (ckWARN(WARN_SYNTAX))
404 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
409 item = s = SvPV(sv, len);
412 itemsize = sv_len_utf8(sv);
413 if (itemsize != len) {
415 if (itemsize > fieldsize) {
416 itemsize = fieldsize;
417 itembytes = itemsize;
418 sv_pos_u2b(sv, &itembytes, 0);
422 send = chophere = s + itembytes;
432 sv_pos_b2u(sv, &itemsize);
437 if (itemsize > fieldsize)
438 itemsize = fieldsize;
439 send = chophere = s + itemsize;
451 item = s = SvPV(sv, len);
454 itemsize = sv_len_utf8(sv);
455 if (itemsize != len) {
457 if (itemsize <= fieldsize) {
458 send = chophere = s + itemsize;
469 itemsize = fieldsize;
470 itembytes = itemsize;
471 sv_pos_u2b(sv, &itembytes, 0);
472 send = chophere = s + itembytes;
473 while (s < send || (s == send && isSPACE(*s))) {
483 if (strchr(PL_chopset, *s))
488 itemsize = chophere - item;
489 sv_pos_b2u(sv, &itemsize);
496 if (itemsize <= fieldsize) {
497 send = chophere = s + itemsize;
508 itemsize = fieldsize;
509 send = chophere = s + itemsize;
510 while (s < send || (s == send && isSPACE(*s))) {
520 if (strchr(PL_chopset, *s))
525 itemsize = chophere - item;
530 arg = fieldsize - itemsize;
539 arg = fieldsize - itemsize;
553 if (UTF8_IS_CONTINUED(*s)) {
554 switch (UTF8SKIP(s)) {
565 if ( !((*t++ = *s++) & ~31) )
573 int ch = *t++ = *s++;
576 if ( !((*t++ = *s++) & ~31) )
585 while (*s && isSPACE(*s))
592 item = s = SvPV(sv, len);
594 item_is_utf = FALSE; /* XXX is this correct? */
606 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
607 sv_catpvn(PL_formtarget, item, itemsize);
608 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
609 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
614 /* If the field is marked with ^ and the value is undefined,
617 if ((arg & 512) && !SvOK(sv)) {
625 /* Formats aren't yet marked for locales, so assume "yes". */
627 STORE_NUMERIC_STANDARD_SET_LOCAL();
628 #if defined(USE_LONG_DOUBLE)
630 sprintf(t, "%#*.*" PERL_PRIfldbl,
631 (int) fieldsize, (int) arg & 255, value);
633 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
638 (int) fieldsize, (int) arg & 255, value);
641 (int) fieldsize, value);
644 RESTORE_NUMERIC_STANDARD();
650 /* If the field is marked with ^ and the value is undefined,
653 if ((arg & 512) && !SvOK(sv)) {
661 /* Formats aren't yet marked for locales, so assume "yes". */
663 STORE_NUMERIC_STANDARD_SET_LOCAL();
664 #if defined(USE_LONG_DOUBLE)
666 sprintf(t, "%#0*.*" PERL_PRIfldbl,
667 (int) fieldsize, (int) arg & 255, value);
668 /* is this legal? I don't have long doubles */
670 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
674 sprintf(t, "%#0*.*f",
675 (int) fieldsize, (int) arg & 255, value);
678 (int) fieldsize, value);
681 RESTORE_NUMERIC_STANDARD();
688 while (t-- > linemark && *t == ' ') ;
696 if (arg) { /* repeat until fields exhausted? */
698 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
699 lines += FmLINES(PL_formtarget);
702 if (strnEQ(linemark, linemark - arg, arg))
703 DIE(aTHX_ "Runaway format");
705 FmLINES(PL_formtarget) = lines;
707 RETURNOP(cLISTOP->op_first);
720 while (*s && isSPACE(*s) && s < send)
724 arg = fieldsize - itemsize;
731 if (strnEQ(s," ",3)) {
732 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
743 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
744 FmLINES(PL_formtarget) += lines;
756 if (PL_stack_base + *PL_markstack_ptr == SP) {
758 if (GIMME_V == G_SCALAR)
759 XPUSHs(sv_2mortal(newSViv(0)));
760 RETURNOP(PL_op->op_next->op_next);
762 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
763 pp_pushmark(); /* push dst */
764 pp_pushmark(); /* push src */
765 ENTER; /* enter outer scope */
768 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
770 ENTER; /* enter inner scope */
773 src = PL_stack_base[*PL_markstack_ptr];
778 if (PL_op->op_type == OP_MAPSTART)
779 pp_pushmark(); /* push top */
780 return ((LOGOP*)PL_op->op_next)->op_other;
785 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
791 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
797 /* first, move source pointer to the next item in the source list */
798 ++PL_markstack_ptr[-1];
800 /* if there are new items, push them into the destination list */
802 /* might need to make room back there first */
803 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
804 /* XXX this implementation is very pessimal because the stack
805 * is repeatedly extended for every set of items. Is possible
806 * to do this without any stack extension or copying at all
807 * by maintaining a separate list over which the map iterates
808 * (like foreach does). --gsar */
810 /* everything in the stack after the destination list moves
811 * towards the end the stack by the amount of room needed */
812 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
814 /* items to shift up (accounting for the moved source pointer) */
815 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
817 /* This optimization is by Ben Tilly and it does
818 * things differently from what Sarathy (gsar)
819 * is describing. The downside of this optimization is
820 * that leaves "holes" (uninitialized and hopefully unused areas)
821 * to the Perl stack, but on the other hand this
822 * shouldn't be a problem. If Sarathy's idea gets
823 * implemented, this optimization should become
824 * irrelevant. --jhi */
826 shift = count; /* Avoid shifting too often --Ben Tilly */
831 PL_markstack_ptr[-1] += shift;
832 *PL_markstack_ptr += shift;
836 /* copy the new items down to the destination list */
837 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
839 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
841 LEAVE; /* exit inner scope */
844 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
847 (void)POPMARK; /* pop top */
848 LEAVE; /* exit outer scope */
849 (void)POPMARK; /* pop src */
850 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
851 (void)POPMARK; /* pop dst */
852 SP = PL_stack_base + POPMARK; /* pop original mark */
853 if (gimme == G_SCALAR) {
857 else if (gimme == G_ARRAY)
864 ENTER; /* enter inner scope */
867 /* set $_ to the new source item */
868 src = PL_stack_base[PL_markstack_ptr[-1]];
872 RETURNOP(cLOGOP->op_other);
878 dSP; dMARK; dORIGMARK;
880 SV **myorigmark = ORIGMARK;
886 OP* nextop = PL_op->op_next;
888 bool hasargs = FALSE;
891 if (gimme != G_ARRAY) {
897 SAVEVPTR(PL_sortcop);
898 if (PL_op->op_flags & OPf_STACKED) {
899 if (PL_op->op_flags & OPf_SPECIAL) {
900 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
901 kid = kUNOP->op_first; /* pass rv2gv */
902 kid = kUNOP->op_first; /* pass leave */
903 PL_sortcop = kid->op_next;
904 stash = CopSTASH(PL_curcop);
907 cv = sv_2cv(*++MARK, &stash, &gv, 0);
908 if (cv && SvPOK(cv)) {
910 char *proto = SvPV((SV*)cv, n_a);
911 if (proto && strEQ(proto, "$$")) {
915 if (!(cv && CvROOT(cv))) {
916 if (cv && CvXSUB(cv)) {
920 SV *tmpstr = sv_newmortal();
921 gv_efullname3(tmpstr, gv, Nullch);
922 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
926 DIE(aTHX_ "Undefined subroutine in sort");
931 PL_sortcop = (OP*)cv;
933 PL_sortcop = CvSTART(cv);
934 SAVEVPTR(CvROOT(cv)->op_ppaddr);
935 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
938 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
944 stash = CopSTASH(PL_curcop);
948 while (MARK < SP) { /* This may or may not shift down one here. */
950 if ((*up = *++MARK)) { /* Weed out nulls. */
952 if (!PL_sortcop && !SvPOK(*up)) {
957 (void)sv_2pv(*up, &n_a);
962 max = --up - myorigmark;
967 bool oldcatch = CATCH_GET;
973 PUSHSTACKi(PERLSI_SORT);
974 if (!hasargs && !is_xsub) {
975 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
976 SAVESPTR(PL_firstgv);
977 SAVESPTR(PL_secondgv);
978 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
979 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
980 PL_sortstash = stash;
983 sv_lock((SV *)PL_firstgv);
984 sv_lock((SV *)PL_secondgv);
986 SAVESPTR(GvSV(PL_firstgv));
987 SAVESPTR(GvSV(PL_secondgv));
990 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
991 if (!(PL_op->op_flags & OPf_SPECIAL)) {
992 cx->cx_type = CXt_SUB;
993 cx->blk_gimme = G_SCALAR;
996 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
998 PL_sortcxix = cxstack_ix;
1000 if (hasargs && !is_xsub) {
1001 /* This is mostly copied from pp_entersub */
1002 AV *av = (AV*)PL_curpad[0];
1005 cx->blk_sub.savearray = GvAV(PL_defgv);
1006 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1007 #endif /* USE_THREADS */
1008 cx->blk_sub.oldcurpad = PL_curpad;
1009 cx->blk_sub.argarray = av;
1011 qsortsv((myorigmark+1), max,
1012 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1014 POPBLOCK(cx,PL_curpm);
1015 PL_stack_sp = newsp;
1017 CATCH_SET(oldcatch);
1022 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1023 qsortsv(ORIGMARK+1, max,
1024 (PL_op->op_private & OPpSORT_NUMERIC)
1025 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1026 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1027 : ( overloading ? amagic_ncmp : sv_ncmp))
1028 : ( (PL_op->op_private & OPpLOCALE)
1031 : sv_cmp_locale_static)
1032 : ( overloading ? amagic_cmp : sv_cmp_static)));
1033 if (PL_op->op_private & OPpSORT_REVERSE) {
1034 SV **p = ORIGMARK+1;
1035 SV **q = ORIGMARK+max;
1045 PL_stack_sp = ORIGMARK + max;
1053 if (GIMME == G_ARRAY)
1055 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1056 return cLOGOP->op_other;
1065 if (GIMME == G_ARRAY) {
1066 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1070 SV *targ = PAD_SV(PL_op->op_targ);
1073 if (PL_op->op_private & OPpFLIP_LINENUM) {
1075 flip = PL_last_in_gv
1076 && (gp_io = GvIOp(PL_last_in_gv))
1077 && SvIV(sv) == (IV)IoLINES(gp_io);
1082 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1083 if (PL_op->op_flags & OPf_SPECIAL) {
1091 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1104 if (GIMME == G_ARRAY) {
1110 if (SvGMAGICAL(left))
1112 if (SvGMAGICAL(right))
1115 if (SvNIOKp(left) || !SvPOKp(left) ||
1116 SvNIOKp(right) || !SvPOKp(right) ||
1117 (looks_like_number(left) && *SvPVX(left) != '0' &&
1118 looks_like_number(right) && *SvPVX(right) != '0'))
1120 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1121 DIE(aTHX_ "Range iterator outside integer range");
1132 sv = sv_2mortal(newSViv(i++));
1137 SV *final = sv_mortalcopy(right);
1139 char *tmps = SvPV(final, len);
1141 sv = sv_mortalcopy(left);
1143 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1145 if (strEQ(SvPVX(sv),tmps))
1147 sv = sv_2mortal(newSVsv(sv));
1154 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1156 if ((PL_op->op_private & OPpFLIP_LINENUM)
1157 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1159 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1160 sv_catpv(targ, "E0");
1171 S_dopoptolabel(pTHX_ char *label)
1174 register PERL_CONTEXT *cx;
1176 for (i = cxstack_ix; i >= 0; i--) {
1178 switch (CxTYPE(cx)) {
1180 if (ckWARN(WARN_EXITING))
1181 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1182 PL_op_name[PL_op->op_type]);
1185 if (ckWARN(WARN_EXITING))
1186 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1187 PL_op_name[PL_op->op_type]);
1190 if (ckWARN(WARN_EXITING))
1191 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1192 PL_op_name[PL_op->op_type]);
1195 if (ckWARN(WARN_EXITING))
1196 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1197 PL_op_name[PL_op->op_type]);
1200 if (ckWARN(WARN_EXITING))
1201 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1202 PL_op_name[PL_op->op_type]);
1205 if (!cx->blk_loop.label ||
1206 strNE(label, cx->blk_loop.label) ) {
1207 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1208 (long)i, cx->blk_loop.label));
1211 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1219 Perl_dowantarray(pTHX)
1221 I32 gimme = block_gimme();
1222 return (gimme == G_VOID) ? G_SCALAR : gimme;
1226 Perl_block_gimme(pTHX)
1230 cxix = dopoptosub(cxstack_ix);
1234 switch (cxstack[cxix].blk_gimme) {
1242 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1249 Perl_is_lvalue_sub(pTHX)
1253 cxix = dopoptosub(cxstack_ix);
1254 assert(cxix >= 0); /* We should only be called from inside subs */
1256 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1257 return cxstack[cxix].blk_sub.lval;
1263 S_dopoptosub(pTHX_ I32 startingblock)
1265 return dopoptosub_at(cxstack, startingblock);
1269 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1272 register PERL_CONTEXT *cx;
1273 for (i = startingblock; i >= 0; i--) {
1275 switch (CxTYPE(cx)) {
1281 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1289 S_dopoptoeval(pTHX_ I32 startingblock)
1292 register PERL_CONTEXT *cx;
1293 for (i = startingblock; i >= 0; i--) {
1295 switch (CxTYPE(cx)) {
1299 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1307 S_dopoptoloop(pTHX_ I32 startingblock)
1310 register PERL_CONTEXT *cx;
1311 for (i = startingblock; i >= 0; i--) {
1313 switch (CxTYPE(cx)) {
1315 if (ckWARN(WARN_EXITING))
1316 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1317 PL_op_name[PL_op->op_type]);
1320 if (ckWARN(WARN_EXITING))
1321 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1322 PL_op_name[PL_op->op_type]);
1325 if (ckWARN(WARN_EXITING))
1326 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1327 PL_op_name[PL_op->op_type]);
1330 if (ckWARN(WARN_EXITING))
1331 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1332 PL_op_name[PL_op->op_type]);
1335 if (ckWARN(WARN_EXITING))
1336 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1337 PL_op_name[PL_op->op_type]);
1340 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1348 Perl_dounwind(pTHX_ I32 cxix)
1350 register PERL_CONTEXT *cx;
1353 while (cxstack_ix > cxix) {
1355 cx = &cxstack[cxstack_ix];
1356 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1357 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1358 /* Note: we don't need to restore the base context info till the end. */
1359 switch (CxTYPE(cx)) {
1362 continue; /* not break */
1384 Perl_qerror(pTHX_ SV *err)
1387 sv_catsv(ERRSV, err);
1389 sv_catsv(PL_errors, err);
1391 Perl_warn(aTHX_ "%"SVf, err);
1396 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1401 register PERL_CONTEXT *cx;
1406 if (PL_in_eval & EVAL_KEEPERR) {
1407 static char prefix[] = "\t(in cleanup) ";
1412 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1415 if (*e != *message || strNE(e,message))
1419 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1420 sv_catpvn(err, prefix, sizeof(prefix)-1);
1421 sv_catpvn(err, message, msglen);
1422 if (ckWARN(WARN_MISC)) {
1423 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1424 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1429 sv_setpvn(ERRSV, message, msglen);
1430 if (PL_hints & HINT_UTF8)
1437 message = SvPVx(ERRSV, msglen);
1439 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1440 && PL_curstackinfo->si_prev)
1449 if (cxix < cxstack_ix)
1452 POPBLOCK(cx,PL_curpm);
1453 if (CxTYPE(cx) != CXt_EVAL) {
1454 PerlIO_write(Perl_error_log, "panic: die ", 11);
1455 PerlIO_write(Perl_error_log, message, msglen);
1460 if (gimme == G_SCALAR)
1461 *++newsp = &PL_sv_undef;
1462 PL_stack_sp = newsp;
1466 /* LEAVE could clobber PL_curcop (see save_re_context())
1467 * XXX it might be better to find a way to avoid messing with
1468 * PL_curcop in save_re_context() instead, but this is a more
1469 * minimal fix --GSAR */
1470 PL_curcop = cx->blk_oldcop;
1472 if (optype == OP_REQUIRE) {
1473 char* msg = SvPVx(ERRSV, n_a);
1474 DIE(aTHX_ "%sCompilation failed in require",
1475 *msg ? msg : "Unknown error\n");
1477 return pop_return();
1481 message = SvPVx(ERRSV, msglen);
1484 /* SFIO can really mess with your errno */
1487 PerlIO *serr = Perl_error_log;
1489 PerlIO_write(serr, message, msglen);
1490 (void)PerlIO_flush(serr);
1503 if (SvTRUE(left) != SvTRUE(right))
1515 RETURNOP(cLOGOP->op_other);
1524 RETURNOP(cLOGOP->op_other);
1530 register I32 cxix = dopoptosub(cxstack_ix);
1531 register PERL_CONTEXT *cx;
1532 register PERL_CONTEXT *ccstack = cxstack;
1533 PERL_SI *top_si = PL_curstackinfo;
1544 /* we may be in a higher stacklevel, so dig down deeper */
1545 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1546 top_si = top_si->si_prev;
1547 ccstack = top_si->si_cxstack;
1548 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1551 if (GIMME != G_ARRAY)
1555 if (PL_DBsub && cxix >= 0 &&
1556 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1560 cxix = dopoptosub_at(ccstack, cxix - 1);
1563 cx = &ccstack[cxix];
1564 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1565 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1566 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1567 field below is defined for any cx. */
1568 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1569 cx = &ccstack[dbcxix];
1572 stashname = CopSTASHPV(cx->blk_oldcop);
1573 if (GIMME != G_ARRAY) {
1575 PUSHs(&PL_sv_undef);
1578 sv_setpv(TARG, stashname);
1585 PUSHs(&PL_sv_undef);
1587 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1588 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1589 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1592 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1593 /* So is ccstack[dbcxix]. */
1595 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1596 PUSHs(sv_2mortal(sv));
1597 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1600 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1601 PUSHs(sv_2mortal(newSViv(0)));
1603 gimme = (I32)cx->blk_gimme;
1604 if (gimme == G_VOID)
1605 PUSHs(&PL_sv_undef);
1607 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1608 if (CxTYPE(cx) == CXt_EVAL) {
1610 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1611 PUSHs(cx->blk_eval.cur_text);
1615 else if (cx->blk_eval.old_namesv) {
1616 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1619 /* eval BLOCK (try blocks have old_namesv == 0) */
1621 PUSHs(&PL_sv_undef);
1622 PUSHs(&PL_sv_undef);
1626 PUSHs(&PL_sv_undef);
1627 PUSHs(&PL_sv_undef);
1629 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1630 && CopSTASH_eq(PL_curcop, PL_debstash))
1632 AV *ary = cx->blk_sub.argarray;
1633 int off = AvARRAY(ary) - AvALLOC(ary);
1637 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1640 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1643 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1644 av_extend(PL_dbargs, AvFILLp(ary) + off);
1645 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1646 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1648 /* XXX only hints propagated via op_private are currently
1649 * visible (others are not easily accessible, since they
1650 * use the global PL_hints) */
1651 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1652 HINT_PRIVATE_MASK)));
1655 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1657 if (old_warnings == pWARN_NONE ||
1658 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1659 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1660 else if (old_warnings == pWARN_ALL ||
1661 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1662 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1664 mask = newSVsv(old_warnings);
1665 PUSHs(sv_2mortal(mask));
1680 sv_reset(tmps, CopSTASH(PL_curcop));
1692 PL_curcop = (COP*)PL_op;
1693 TAINT_NOT; /* Each statement is presumed innocent */
1694 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1697 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1701 register PERL_CONTEXT *cx;
1702 I32 gimme = G_ARRAY;
1709 DIE(aTHX_ "No DB::DB routine defined");
1711 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1712 /* don't do recursive DB::DB call */
1724 push_return(PL_op->op_next);
1725 PUSHBLOCK(cx, CXt_SUB, SP);
1728 (void)SvREFCNT_inc(cv);
1729 SAVEVPTR(PL_curpad);
1730 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1731 RETURNOP(CvSTART(cv));
1745 register PERL_CONTEXT *cx;
1746 I32 gimme = GIMME_V;
1748 U32 cxtype = CXt_LOOP;
1757 if (PL_op->op_flags & OPf_SPECIAL) {
1758 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1759 SAVEGENERICSV(*svp);
1763 #endif /* USE_THREADS */
1764 if (PL_op->op_targ) {
1765 #ifndef USE_ITHREADS
1766 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1769 SAVEPADSV(PL_op->op_targ);
1770 iterdata = (void*)PL_op->op_targ;
1771 cxtype |= CXp_PADVAR;
1776 svp = &GvSV(gv); /* symbol table variable */
1777 SAVEGENERICSV(*svp);
1780 iterdata = (void*)gv;
1786 PUSHBLOCK(cx, cxtype, SP);
1788 PUSHLOOP(cx, iterdata, MARK);
1790 PUSHLOOP(cx, svp, MARK);
1792 if (PL_op->op_flags & OPf_STACKED) {
1793 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1794 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1796 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1797 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1798 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1799 looks_like_number((SV*)cx->blk_loop.iterary) &&
1800 *SvPVX(cx->blk_loop.iterary) != '0'))
1802 if (SvNV(sv) < IV_MIN ||
1803 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1804 DIE(aTHX_ "Range iterator outside integer range");
1805 cx->blk_loop.iterix = SvIV(sv);
1806 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1809 cx->blk_loop.iterlval = newSVsv(sv);
1813 cx->blk_loop.iterary = PL_curstack;
1814 AvFILLp(PL_curstack) = SP - PL_stack_base;
1815 cx->blk_loop.iterix = MARK - PL_stack_base;
1824 register PERL_CONTEXT *cx;
1825 I32 gimme = GIMME_V;
1831 PUSHBLOCK(cx, CXt_LOOP, SP);
1832 PUSHLOOP(cx, 0, SP);
1840 register PERL_CONTEXT *cx;
1848 newsp = PL_stack_base + cx->blk_loop.resetsp;
1851 if (gimme == G_VOID)
1853 else if (gimme == G_SCALAR) {
1855 *++newsp = sv_mortalcopy(*SP);
1857 *++newsp = &PL_sv_undef;
1861 *++newsp = sv_mortalcopy(*++mark);
1862 TAINT_NOT; /* Each item is independent */
1868 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1869 PL_curpm = newpm; /* ... and pop $1 et al */
1881 register PERL_CONTEXT *cx;
1882 bool popsub2 = FALSE;
1883 bool clear_errsv = FALSE;
1890 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1891 if (cxstack_ix == PL_sortcxix
1892 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1894 if (cxstack_ix > PL_sortcxix)
1895 dounwind(PL_sortcxix);
1896 AvARRAY(PL_curstack)[1] = *SP;
1897 PL_stack_sp = PL_stack_base + 1;
1902 cxix = dopoptosub(cxstack_ix);
1904 DIE(aTHX_ "Can't return outside a subroutine");
1905 if (cxix < cxstack_ix)
1909 switch (CxTYPE(cx)) {
1914 if (!(PL_in_eval & EVAL_KEEPERR))
1920 if (optype == OP_REQUIRE &&
1921 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1923 /* Unassume the success we assumed earlier. */
1924 SV *nsv = cx->blk_eval.old_namesv;
1925 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1926 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1933 DIE(aTHX_ "panic: return");
1937 if (gimme == G_SCALAR) {
1940 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1942 *++newsp = SvREFCNT_inc(*SP);
1947 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1949 *++newsp = sv_mortalcopy(sv);
1954 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1957 *++newsp = sv_mortalcopy(*SP);
1960 *++newsp = &PL_sv_undef;
1962 else if (gimme == G_ARRAY) {
1963 while (++MARK <= SP) {
1964 *++newsp = (popsub2 && SvTEMP(*MARK))
1965 ? *MARK : sv_mortalcopy(*MARK);
1966 TAINT_NOT; /* Each item is independent */
1969 PL_stack_sp = newsp;
1971 /* Stack values are safe: */
1973 POPSUB(cx,sv); /* release CV and @_ ... */
1977 PL_curpm = newpm; /* ... and pop $1 et al */
1983 return pop_return();
1990 register PERL_CONTEXT *cx;
2000 if (PL_op->op_flags & OPf_SPECIAL) {
2001 cxix = dopoptoloop(cxstack_ix);
2003 DIE(aTHX_ "Can't \"last\" outside a loop block");
2006 cxix = dopoptolabel(cPVOP->op_pv);
2008 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2010 if (cxix < cxstack_ix)
2015 switch (CxTYPE(cx)) {
2018 newsp = PL_stack_base + cx->blk_loop.resetsp;
2019 nextop = cx->blk_loop.last_op->op_next;
2023 nextop = pop_return();
2027 nextop = pop_return();
2031 nextop = pop_return();
2034 DIE(aTHX_ "panic: last");
2038 if (gimme == G_SCALAR) {
2040 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2041 ? *SP : sv_mortalcopy(*SP);
2043 *++newsp = &PL_sv_undef;
2045 else if (gimme == G_ARRAY) {
2046 while (++MARK <= SP) {
2047 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2048 ? *MARK : sv_mortalcopy(*MARK);
2049 TAINT_NOT; /* Each item is independent */
2055 /* Stack values are safe: */
2058 POPLOOP(cx); /* release loop vars ... */
2062 POPSUB(cx,sv); /* release CV and @_ ... */
2065 PL_curpm = newpm; /* ... and pop $1 et al */
2075 register PERL_CONTEXT *cx;
2078 if (PL_op->op_flags & OPf_SPECIAL) {
2079 cxix = dopoptoloop(cxstack_ix);
2081 DIE(aTHX_ "Can't \"next\" outside a loop block");
2084 cxix = dopoptolabel(cPVOP->op_pv);
2086 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2088 if (cxix < cxstack_ix)
2091 /* clear off anything above the scope we're re-entering, but
2092 * save the rest until after a possible continue block */
2093 inner = PL_scopestack_ix;
2095 if (PL_scopestack_ix < inner)
2096 leave_scope(PL_scopestack[PL_scopestack_ix]);
2097 return cx->blk_loop.next_op;
2103 register PERL_CONTEXT *cx;
2106 if (PL_op->op_flags & OPf_SPECIAL) {
2107 cxix = dopoptoloop(cxstack_ix);
2109 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2112 cxix = dopoptolabel(cPVOP->op_pv);
2114 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2116 if (cxix < cxstack_ix)
2120 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2121 LEAVE_SCOPE(oldsave);
2122 return cx->blk_loop.redo_op;
2126 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2130 static char too_deep[] = "Target of goto is too deeply nested";
2133 Perl_croak(aTHX_ too_deep);
2134 if (o->op_type == OP_LEAVE ||
2135 o->op_type == OP_SCOPE ||
2136 o->op_type == OP_LEAVELOOP ||
2137 o->op_type == OP_LEAVETRY)
2139 *ops++ = cUNOPo->op_first;
2141 Perl_croak(aTHX_ too_deep);
2144 if (o->op_flags & OPf_KIDS) {
2145 /* First try all the kids at this level, since that's likeliest. */
2146 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2147 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2148 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2151 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2152 if (kid == PL_lastgotoprobe)
2154 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2156 (ops[-1]->op_type != OP_NEXTSTATE &&
2157 ops[-1]->op_type != OP_DBSTATE)))
2159 if ((o = dofindlabel(kid, label, ops, oplimit)))
2178 register PERL_CONTEXT *cx;
2179 #define GOTO_DEPTH 64
2180 OP *enterops[GOTO_DEPTH];
2182 int do_dump = (PL_op->op_type == OP_DUMP);
2183 static char must_have_label[] = "goto must have label";
2186 if (PL_op->op_flags & OPf_STACKED) {
2190 /* This egregious kludge implements goto &subroutine */
2191 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2193 register PERL_CONTEXT *cx;
2194 CV* cv = (CV*)SvRV(sv);
2200 if (!CvROOT(cv) && !CvXSUB(cv)) {
2205 /* autoloaded stub? */
2206 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2208 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2209 GvNAMELEN(gv), FALSE);
2210 if (autogv && (cv = GvCV(autogv)))
2212 tmpstr = sv_newmortal();
2213 gv_efullname3(tmpstr, gv, Nullch);
2214 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2216 DIE(aTHX_ "Goto undefined subroutine");
2219 /* First do some returnish stuff. */
2220 cxix = dopoptosub(cxstack_ix);
2222 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2223 if (cxix < cxstack_ix)
2226 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2227 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2229 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2230 /* put @_ back onto stack */
2231 AV* av = cx->blk_sub.argarray;
2233 items = AvFILLp(av) + 1;
2235 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2236 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2237 PL_stack_sp += items;
2239 SvREFCNT_dec(GvAV(PL_defgv));
2240 GvAV(PL_defgv) = cx->blk_sub.savearray;
2241 #endif /* USE_THREADS */
2242 /* abandon @_ if it got reified */
2244 (void)sv_2mortal((SV*)av); /* delay until return */
2246 av_extend(av, items-1);
2247 AvFLAGS(av) = AVf_REIFY;
2248 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2251 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2254 av = (AV*)PL_curpad[0];
2256 av = GvAV(PL_defgv);
2258 items = AvFILLp(av) + 1;
2260 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2261 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2262 PL_stack_sp += items;
2264 if (CxTYPE(cx) == CXt_SUB &&
2265 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2266 SvREFCNT_dec(cx->blk_sub.cv);
2267 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2268 LEAVE_SCOPE(oldsave);
2270 /* Now do some callish stuff. */
2273 #ifdef PERL_XSUB_OLDSTYLE
2274 if (CvOLDSTYLE(cv)) {
2275 I32 (*fp3)(int,int,int);
2280 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2281 items = (*fp3)(CvXSUBANY(cv).any_i32,
2282 mark - PL_stack_base + 1,
2284 SP = PL_stack_base + items;
2287 #endif /* PERL_XSUB_OLDSTYLE */
2292 PL_stack_sp--; /* There is no cv arg. */
2293 /* Push a mark for the start of arglist */
2295 (void)(*CvXSUB(cv))(aTHXo_ cv);
2296 /* Pop the current context like a decent sub should */
2297 POPBLOCK(cx, PL_curpm);
2298 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2301 return pop_return();
2304 AV* padlist = CvPADLIST(cv);
2305 SV** svp = AvARRAY(padlist);
2306 if (CxTYPE(cx) == CXt_EVAL) {
2307 PL_in_eval = cx->blk_eval.old_in_eval;
2308 PL_eval_root = cx->blk_eval.old_eval_root;
2309 cx->cx_type = CXt_SUB;
2310 cx->blk_sub.hasargs = 0;
2312 cx->blk_sub.cv = cv;
2313 cx->blk_sub.olddepth = CvDEPTH(cv);
2315 if (CvDEPTH(cv) < 2)
2316 (void)SvREFCNT_inc(cv);
2317 else { /* save temporaries on recursion? */
2318 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2319 sub_crush_depth(cv);
2320 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2321 AV *newpad = newAV();
2322 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2323 I32 ix = AvFILLp((AV*)svp[1]);
2324 I32 names_fill = AvFILLp((AV*)svp[0]);
2325 svp = AvARRAY(svp[0]);
2326 for ( ;ix > 0; ix--) {
2327 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2328 char *name = SvPVX(svp[ix]);
2329 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2332 /* outer lexical or anon code */
2333 av_store(newpad, ix,
2334 SvREFCNT_inc(oldpad[ix]) );
2336 else { /* our own lexical */
2338 av_store(newpad, ix, sv = (SV*)newAV());
2339 else if (*name == '%')
2340 av_store(newpad, ix, sv = (SV*)newHV());
2342 av_store(newpad, ix, sv = NEWSV(0,0));
2346 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2347 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2350 av_store(newpad, ix, sv = NEWSV(0,0));
2354 if (cx->blk_sub.hasargs) {
2357 av_store(newpad, 0, (SV*)av);
2358 AvFLAGS(av) = AVf_REIFY;
2360 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2361 AvFILLp(padlist) = CvDEPTH(cv);
2362 svp = AvARRAY(padlist);
2366 if (!cx->blk_sub.hasargs) {
2367 AV* av = (AV*)PL_curpad[0];
2369 items = AvFILLp(av) + 1;
2371 /* Mark is at the end of the stack. */
2373 Copy(AvARRAY(av), SP + 1, items, SV*);
2378 #endif /* USE_THREADS */
2379 SAVEVPTR(PL_curpad);
2380 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2382 if (cx->blk_sub.hasargs)
2383 #endif /* USE_THREADS */
2385 AV* av = (AV*)PL_curpad[0];
2389 cx->blk_sub.savearray = GvAV(PL_defgv);
2390 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2391 #endif /* USE_THREADS */
2392 cx->blk_sub.oldcurpad = PL_curpad;
2393 cx->blk_sub.argarray = av;
2396 if (items >= AvMAX(av) + 1) {
2398 if (AvARRAY(av) != ary) {
2399 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2400 SvPVX(av) = (char*)ary;
2402 if (items >= AvMAX(av) + 1) {
2403 AvMAX(av) = items - 1;
2404 Renew(ary,items+1,SV*);
2406 SvPVX(av) = (char*)ary;
2409 Copy(mark,AvARRAY(av),items,SV*);
2410 AvFILLp(av) = items - 1;
2411 assert(!AvREAL(av));
2418 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2420 * We do not care about using sv to call CV;
2421 * it's for informational purposes only.
2423 SV *sv = GvSV(PL_DBsub);
2426 if (PERLDB_SUB_NN) {
2427 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2430 gv_efullname3(sv, CvGV(cv), Nullch);
2433 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2434 PUSHMARK( PL_stack_sp );
2435 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2439 RETURNOP(CvSTART(cv));
2443 label = SvPV(sv,n_a);
2444 if (!(do_dump || *label))
2445 DIE(aTHX_ must_have_label);
2448 else if (PL_op->op_flags & OPf_SPECIAL) {
2450 DIE(aTHX_ must_have_label);
2453 label = cPVOP->op_pv;
2455 if (label && *label) {
2460 PL_lastgotoprobe = 0;
2462 for (ix = cxstack_ix; ix >= 0; ix--) {
2464 switch (CxTYPE(cx)) {
2466 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2469 gotoprobe = cx->blk_oldcop->op_sibling;
2475 gotoprobe = cx->blk_oldcop->op_sibling;
2477 gotoprobe = PL_main_root;
2480 if (CvDEPTH(cx->blk_sub.cv)) {
2481 gotoprobe = CvROOT(cx->blk_sub.cv);
2487 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2490 DIE(aTHX_ "panic: goto");
2491 gotoprobe = PL_main_root;
2495 retop = dofindlabel(gotoprobe, label,
2496 enterops, enterops + GOTO_DEPTH);
2500 PL_lastgotoprobe = gotoprobe;
2503 DIE(aTHX_ "Can't find label %s", label);
2505 /* pop unwanted frames */
2507 if (ix < cxstack_ix) {
2514 oldsave = PL_scopestack[PL_scopestack_ix];
2515 LEAVE_SCOPE(oldsave);
2518 /* push wanted frames */
2520 if (*enterops && enterops[1]) {
2522 for (ix = 1; enterops[ix]; ix++) {
2523 PL_op = enterops[ix];
2524 /* Eventually we may want to stack the needed arguments
2525 * for each op. For now, we punt on the hard ones. */
2526 if (PL_op->op_type == OP_ENTERITER)
2527 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2528 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2536 if (!retop) retop = PL_main_start;
2538 PL_restartop = retop;
2539 PL_do_undump = TRUE;
2543 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2544 PL_do_undump = FALSE;
2560 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2564 PL_exit_flags |= PERL_EXIT_EXPECTED;
2566 PUSHs(&PL_sv_undef);
2574 NV value = SvNVx(GvSV(cCOP->cop_gv));
2575 register I32 match = I_32(value);
2578 if (((NV)match) > value)
2579 --match; /* was fractional--truncate other way */
2581 match -= cCOP->uop.scop.scop_offset;
2584 else if (match > cCOP->uop.scop.scop_max)
2585 match = cCOP->uop.scop.scop_max;
2586 PL_op = cCOP->uop.scop.scop_next[match];
2596 PL_op = PL_op->op_next; /* can't assume anything */
2599 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2600 match -= cCOP->uop.scop.scop_offset;
2603 else if (match > cCOP->uop.scop.scop_max)
2604 match = cCOP->uop.scop.scop_max;
2605 PL_op = cCOP->uop.scop.scop_next[match];
2614 S_save_lines(pTHX_ AV *array, SV *sv)
2616 register char *s = SvPVX(sv);
2617 register char *send = SvPVX(sv) + SvCUR(sv);
2619 register I32 line = 1;
2621 while (s && s < send) {
2622 SV *tmpstr = NEWSV(85,0);
2624 sv_upgrade(tmpstr, SVt_PVMG);
2625 t = strchr(s, '\n');
2631 sv_setpvn(tmpstr, s, t - s);
2632 av_store(array, line++, tmpstr);
2637 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2639 S_docatch_body(pTHX_ va_list args)
2641 return docatch_body();
2646 S_docatch_body(pTHX)
2653 S_docatch(pTHX_ OP *o)
2657 volatile PERL_SI *cursi = PL_curstackinfo;
2661 assert(CATCH_GET == TRUE);
2664 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2666 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2672 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2678 if (PL_restartop && cursi == PL_curstackinfo) {
2679 PL_op = PL_restartop;
2696 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2697 /* sv Text to convert to OP tree. */
2698 /* startop op_free() this to undo. */
2699 /* code Short string id of the caller. */
2701 dSP; /* Make POPBLOCK work. */
2704 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2708 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2709 char *tmpbuf = tbuf;
2715 /* switch to eval mode */
2717 if (PL_curcop == &PL_compiling) {
2718 SAVECOPSTASH_FREE(&PL_compiling);
2719 CopSTASH_set(&PL_compiling, PL_curstash);
2721 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2722 SV *sv = sv_newmortal();
2723 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2724 code, (unsigned long)++PL_evalseq,
2725 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2729 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2730 SAVECOPFILE_FREE(&PL_compiling);
2731 CopFILE_set(&PL_compiling, tmpbuf+2);
2732 SAVECOPLINE(&PL_compiling);
2733 CopLINE_set(&PL_compiling, 1);
2734 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2735 deleting the eval's FILEGV from the stash before gv_check() runs
2736 (i.e. before run-time proper). To work around the coredump that
2737 ensues, we always turn GvMULTI_on for any globals that were
2738 introduced within evals. See force_ident(). GSAR 96-10-12 */
2739 safestr = savepv(tmpbuf);
2740 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2742 #ifdef OP_IN_REGISTER
2747 PL_hints &= HINT_UTF8;
2750 PL_op->op_type = OP_ENTEREVAL;
2751 PL_op->op_flags = 0; /* Avoid uninit warning. */
2752 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2753 PUSHEVAL(cx, 0, Nullgv);
2754 rop = doeval(G_SCALAR, startop);
2755 POPBLOCK(cx,PL_curpm);
2758 (*startop)->op_type = OP_NULL;
2759 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2761 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2763 if (PL_curcop == &PL_compiling)
2764 PL_compiling.op_private = PL_hints;
2765 #ifdef OP_IN_REGISTER
2771 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2773 S_doeval(pTHX_ int gimme, OP** startop)
2781 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2782 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2787 /* set up a scratch pad */
2790 SAVEVPTR(PL_curpad);
2791 SAVESPTR(PL_comppad);
2792 SAVESPTR(PL_comppad_name);
2793 SAVEI32(PL_comppad_name_fill);
2794 SAVEI32(PL_min_intro_pending);
2795 SAVEI32(PL_max_intro_pending);
2798 for (i = cxstack_ix - 1; i >= 0; i--) {
2799 PERL_CONTEXT *cx = &cxstack[i];
2800 if (CxTYPE(cx) == CXt_EVAL)
2802 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2803 caller = cx->blk_sub.cv;
2808 SAVESPTR(PL_compcv);
2809 PL_compcv = (CV*)NEWSV(1104,0);
2810 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2811 CvEVAL_on(PL_compcv);
2813 CvOWNER(PL_compcv) = 0;
2814 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2815 MUTEX_INIT(CvMUTEXP(PL_compcv));
2816 #endif /* USE_THREADS */
2818 PL_comppad = newAV();
2819 av_push(PL_comppad, Nullsv);
2820 PL_curpad = AvARRAY(PL_comppad);
2821 PL_comppad_name = newAV();
2822 PL_comppad_name_fill = 0;
2823 PL_min_intro_pending = 0;
2826 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2827 PL_curpad[0] = (SV*)newAV();
2828 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2829 #endif /* USE_THREADS */
2831 comppadlist = newAV();
2832 AvREAL_off(comppadlist);
2833 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2834 av_store(comppadlist, 1, (SV*)PL_comppad);
2835 CvPADLIST(PL_compcv) = comppadlist;
2838 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2840 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2843 SAVEFREESV(PL_compcv);
2845 /* make sure we compile in the right package */
2847 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2848 SAVESPTR(PL_curstash);
2849 PL_curstash = CopSTASH(PL_curcop);
2851 SAVESPTR(PL_beginav);
2852 PL_beginav = newAV();
2853 SAVEFREESV(PL_beginav);
2854 SAVEI32(PL_error_count);
2856 /* try to compile it */
2858 PL_eval_root = Nullop;
2860 PL_curcop = &PL_compiling;
2861 PL_curcop->cop_arybase = 0;
2862 SvREFCNT_dec(PL_rs);
2863 PL_rs = newSVpvn("\n", 1);
2864 if (saveop && saveop->op_flags & OPf_SPECIAL)
2865 PL_in_eval |= EVAL_KEEPERR;
2868 if (yyparse() || PL_error_count || !PL_eval_root) {
2872 I32 optype = 0; /* Might be reset by POPEVAL. */
2877 op_free(PL_eval_root);
2878 PL_eval_root = Nullop;
2880 SP = PL_stack_base + POPMARK; /* pop original mark */
2882 POPBLOCK(cx,PL_curpm);
2888 if (optype == OP_REQUIRE) {
2889 char* msg = SvPVx(ERRSV, n_a);
2890 DIE(aTHX_ "%sCompilation failed in require",
2891 *msg ? msg : "Unknown error\n");
2894 char* msg = SvPVx(ERRSV, n_a);
2896 POPBLOCK(cx,PL_curpm);
2898 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2899 (*msg ? msg : "Unknown error\n"));
2901 SvREFCNT_dec(PL_rs);
2902 PL_rs = SvREFCNT_inc(PL_nrs);
2904 MUTEX_LOCK(&PL_eval_mutex);
2906 COND_SIGNAL(&PL_eval_cond);
2907 MUTEX_UNLOCK(&PL_eval_mutex);
2908 #endif /* USE_THREADS */
2911 SvREFCNT_dec(PL_rs);
2912 PL_rs = SvREFCNT_inc(PL_nrs);
2913 CopLINE_set(&PL_compiling, 0);
2915 *startop = PL_eval_root;
2916 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2917 CvOUTSIDE(PL_compcv) = Nullcv;
2919 SAVEFREEOP(PL_eval_root);
2921 scalarvoid(PL_eval_root);
2922 else if (gimme & G_ARRAY)
2925 scalar(PL_eval_root);
2927 DEBUG_x(dump_eval());
2929 /* Register with debugger: */
2930 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2931 CV *cv = get_cv("DB::postponed", FALSE);
2935 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2937 call_sv((SV*)cv, G_DISCARD);
2941 /* compiled okay, so do it */
2943 CvDEPTH(PL_compcv) = 1;
2944 SP = PL_stack_base + POPMARK; /* pop original mark */
2945 PL_op = saveop; /* The caller may need it. */
2946 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2948 MUTEX_LOCK(&PL_eval_mutex);
2950 COND_SIGNAL(&PL_eval_cond);
2951 MUTEX_UNLOCK(&PL_eval_mutex);
2952 #endif /* USE_THREADS */
2954 RETURNOP(PL_eval_start);
2958 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2960 STRLEN namelen = strlen(name);
2963 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2964 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2965 char *pmc = SvPV_nolen(pmcsv);
2968 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2969 fp = PerlIO_open(name, mode);
2972 if (PerlLIO_stat(name, &pmstat) < 0 ||
2973 pmstat.st_mtime < pmcstat.st_mtime)
2975 fp = PerlIO_open(pmc, mode);
2978 fp = PerlIO_open(name, mode);
2981 SvREFCNT_dec(pmcsv);
2984 fp = PerlIO_open(name, mode);
2992 register PERL_CONTEXT *cx;
2997 SV *namesv = Nullsv;
2999 I32 gimme = G_SCALAR;
3000 PerlIO *tryrsfp = 0;
3002 int filter_has_file = 0;
3003 GV *filter_child_proc = 0;
3004 SV *filter_state = 0;
3009 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3010 UV rev = 0, ver = 0, sver = 0;
3012 U8 *s = (U8*)SvPVX(sv);
3013 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3015 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3018 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3021 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3024 if (PERL_REVISION < rev
3025 || (PERL_REVISION == rev
3026 && (PERL_VERSION < ver
3027 || (PERL_VERSION == ver
3028 && PERL_SUBVERSION < sver))))
3030 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3031 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3032 PERL_VERSION, PERL_SUBVERSION);
3036 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3037 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3038 + ((NV)PERL_SUBVERSION/(NV)1000000)
3039 + 0.00000099 < SvNV(sv))
3043 NV nver = (nrev - rev) * 1000;
3044 UV ver = (UV)(nver + 0.0009);
3045 NV nsver = (nver - ver) * 1000;
3046 UV sver = (UV)(nsver + 0.0009);
3048 /* help out with the "use 5.6" confusion */
3049 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3050 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3051 "this is only v%d.%d.%d, stopped"
3052 " (did you mean v%"UVuf".%"UVuf".0?)",
3053 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3054 PERL_SUBVERSION, rev, ver/100);
3057 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3058 "this is only v%d.%d.%d, stopped",
3059 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3066 name = SvPV(sv, len);
3067 if (!(name && len > 0 && *name))
3068 DIE(aTHX_ "Null filename used");
3069 TAINT_PROPER("require");
3070 if (PL_op->op_type == OP_REQUIRE &&
3071 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3072 *svp != &PL_sv_undef)
3075 /* prepare to compile file */
3077 #ifdef MACOS_TRADITIONAL
3078 if (PERL_FILE_IS_ABSOLUTE(name)
3079 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3082 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3083 /* We consider paths of the form :a:b ambiguous and interpret them first
3084 as global then as local
3086 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3092 if (PERL_FILE_IS_ABSOLUTE(name)
3093 || (*name == '.' && (name[1] == '/' ||
3094 (name[1] == '.' && name[2] == '/'))))
3097 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3101 AV *ar = GvAVn(PL_incgv);
3105 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3108 namesv = NEWSV(806, 0);
3109 for (i = 0; i <= AvFILL(ar); i++) {
3110 SV *dirsv = *av_fetch(ar, i, TRUE);
3116 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3117 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3120 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3121 PTR2UV(SvANY(loader)), name);
3122 tryname = SvPVX(namesv);
3133 if (sv_isobject(loader))
3134 count = call_method("INC", G_ARRAY);
3136 count = call_sv(loader, G_ARRAY);
3146 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3150 if (SvTYPE(arg) == SVt_PVGV) {
3151 IO *io = GvIO((GV *)arg);
3156 tryrsfp = IoIFP(io);
3157 if (IoTYPE(io) == IoTYPE_PIPE) {
3158 /* reading from a child process doesn't
3159 nest -- when returning from reading
3160 the inner module, the outer one is
3161 unreadable (closed?) I've tried to
3162 save the gv to manage the lifespan of
3163 the pipe, but this didn't help. XXX */
3164 filter_child_proc = (GV *)arg;
3165 (void)SvREFCNT_inc(filter_child_proc);
3168 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3169 PerlIO_close(IoOFP(io));
3181 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3183 (void)SvREFCNT_inc(filter_sub);
3186 filter_state = SP[i];
3187 (void)SvREFCNT_inc(filter_state);
3191 tryrsfp = PerlIO_open("/dev/null",
3205 filter_has_file = 0;
3206 if (filter_child_proc) {
3207 SvREFCNT_dec(filter_child_proc);
3208 filter_child_proc = 0;
3211 SvREFCNT_dec(filter_state);
3215 SvREFCNT_dec(filter_sub);
3220 char *dir = SvPVx(dirsv, n_a);
3221 #ifdef MACOS_TRADITIONAL
3223 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3227 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3229 sv_setpv(namesv, unixdir);
3230 sv_catpv(namesv, unixname);
3232 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3235 TAINT_PROPER("require");
3236 tryname = SvPVX(namesv);
3237 #ifdef MACOS_TRADITIONAL
3239 /* Convert slashes in the name part, but not the directory part, to colons */
3241 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3245 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3247 if (tryname[0] == '.' && tryname[1] == '/')
3255 SAVECOPFILE_FREE(&PL_compiling);
3256 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3257 SvREFCNT_dec(namesv);
3259 if (PL_op->op_type == OP_REQUIRE) {
3260 char *msgstr = name;
3261 if (namesv) { /* did we lookup @INC? */
3262 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3263 SV *dirmsgsv = NEWSV(0, 0);
3264 AV *ar = GvAVn(PL_incgv);
3266 sv_catpvn(msg, " in @INC", 8);
3267 if (instr(SvPVX(msg), ".h "))
3268 sv_catpv(msg, " (change .h to .ph maybe?)");
3269 if (instr(SvPVX(msg), ".ph "))
3270 sv_catpv(msg, " (did you run h2ph?)");
3271 sv_catpv(msg, " (@INC contains:");
3272 for (i = 0; i <= AvFILL(ar); i++) {
3273 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3274 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3275 sv_catsv(msg, dirmsgsv);
3277 sv_catpvn(msg, ")", 1);
3278 SvREFCNT_dec(dirmsgsv);
3279 msgstr = SvPV_nolen(msg);
3281 DIE(aTHX_ "Can't locate %s", msgstr);
3287 SETERRNO(0, SS$_NORMAL);
3289 /* Assume success here to prevent recursive requirement. */
3290 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3291 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3295 lex_start(sv_2mortal(newSVpvn("",0)));
3296 SAVEGENERICSV(PL_rsfp_filters);
3297 PL_rsfp_filters = Nullav;
3302 SAVESPTR(PL_compiling.cop_warnings);
3303 if (PL_dowarn & G_WARN_ALL_ON)
3304 PL_compiling.cop_warnings = pWARN_ALL ;
3305 else if (PL_dowarn & G_WARN_ALL_OFF)
3306 PL_compiling.cop_warnings = pWARN_NONE ;
3308 PL_compiling.cop_warnings = pWARN_STD ;
3309 SAVESPTR(PL_compiling.cop_io);
3310 PL_compiling.cop_io = Nullsv;
3312 if (filter_sub || filter_child_proc) {
3313 SV *datasv = filter_add(run_user_filter, Nullsv);
3314 IoLINES(datasv) = filter_has_file;
3315 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3316 IoTOP_GV(datasv) = (GV *)filter_state;
3317 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3320 /* switch to eval mode */
3321 push_return(PL_op->op_next);
3322 PUSHBLOCK(cx, CXt_EVAL, SP);
3323 PUSHEVAL(cx, name, Nullgv);
3325 SAVECOPLINE(&PL_compiling);
3326 CopLINE_set(&PL_compiling, 0);
3330 MUTEX_LOCK(&PL_eval_mutex);
3331 if (PL_eval_owner && PL_eval_owner != thr)
3332 while (PL_eval_owner)
3333 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3334 PL_eval_owner = thr;
3335 MUTEX_UNLOCK(&PL_eval_mutex);
3336 #endif /* USE_THREADS */
3337 return DOCATCH(doeval(G_SCALAR, NULL));
3342 return pp_require();
3348 register PERL_CONTEXT *cx;
3350 I32 gimme = GIMME_V, was = PL_sub_generation;
3351 char tbuf[TYPE_DIGITS(long) + 12];
3352 char *tmpbuf = tbuf;
3357 if (!SvPV(sv,len) || !len)
3359 TAINT_PROPER("eval");
3365 /* switch to eval mode */
3367 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3368 SV *sv = sv_newmortal();
3369 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3370 (unsigned long)++PL_evalseq,
3371 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3375 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3376 SAVECOPFILE_FREE(&PL_compiling);
3377 CopFILE_set(&PL_compiling, tmpbuf+2);
3378 SAVECOPLINE(&PL_compiling);
3379 CopLINE_set(&PL_compiling, 1);
3380 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3381 deleting the eval's FILEGV from the stash before gv_check() runs
3382 (i.e. before run-time proper). To work around the coredump that
3383 ensues, we always turn GvMULTI_on for any globals that were
3384 introduced within evals. See force_ident(). GSAR 96-10-12 */
3385 safestr = savepv(tmpbuf);
3386 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3388 PL_hints = PL_op->op_targ;
3389 SAVESPTR(PL_compiling.cop_warnings);
3390 if (specialWARN(PL_curcop->cop_warnings))
3391 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3393 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3394 SAVEFREESV(PL_compiling.cop_warnings);
3396 SAVESPTR(PL_compiling.cop_io);
3397 if (specialCopIO(PL_curcop->cop_io))
3398 PL_compiling.cop_io = PL_curcop->cop_io;
3400 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3401 SAVEFREESV(PL_compiling.cop_io);
3404 push_return(PL_op->op_next);
3405 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3406 PUSHEVAL(cx, 0, Nullgv);
3408 /* prepare to compile string */
3410 if (PERLDB_LINE && PL_curstash != PL_debstash)
3411 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3414 MUTEX_LOCK(&PL_eval_mutex);
3415 if (PL_eval_owner && PL_eval_owner != thr)
3416 while (PL_eval_owner)
3417 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3418 PL_eval_owner = thr;
3419 MUTEX_UNLOCK(&PL_eval_mutex);
3420 #endif /* USE_THREADS */
3421 ret = doeval(gimme, NULL);
3422 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3423 && ret != PL_op->op_next) { /* Successive compilation. */
3424 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3426 return DOCATCH(ret);
3436 register PERL_CONTEXT *cx;
3438 U8 save_flags = PL_op -> op_flags;
3443 retop = pop_return();
3446 if (gimme == G_VOID)
3448 else if (gimme == G_SCALAR) {
3451 if (SvFLAGS(TOPs) & SVs_TEMP)
3454 *MARK = sv_mortalcopy(TOPs);
3458 *MARK = &PL_sv_undef;
3463 /* in case LEAVE wipes old return values */
3464 for (mark = newsp + 1; mark <= SP; mark++) {
3465 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3466 *mark = sv_mortalcopy(*mark);
3467 TAINT_NOT; /* Each item is independent */
3471 PL_curpm = newpm; /* Don't pop $1 et al till now */
3474 assert(CvDEPTH(PL_compcv) == 1);
3476 CvDEPTH(PL_compcv) = 0;
3479 if (optype == OP_REQUIRE &&
3480 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3482 /* Unassume the success we assumed earlier. */
3483 SV *nsv = cx->blk_eval.old_namesv;
3484 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3485 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3486 /* die_where() did LEAVE, or we won't be here */
3490 if (!(save_flags & OPf_SPECIAL))
3500 register PERL_CONTEXT *cx;
3501 I32 gimme = GIMME_V;
3506 push_return(cLOGOP->op_other->op_next);
3507 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3509 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3511 PL_in_eval = EVAL_INEVAL;
3514 return DOCATCH(PL_op->op_next);
3524 register PERL_CONTEXT *cx;
3532 if (gimme == G_VOID)
3534 else if (gimme == G_SCALAR) {
3537 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3540 *MARK = sv_mortalcopy(TOPs);
3544 *MARK = &PL_sv_undef;
3549 /* in case LEAVE wipes old return values */
3550 for (mark = newsp + 1; mark <= SP; mark++) {
3551 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3552 *mark = sv_mortalcopy(*mark);
3553 TAINT_NOT; /* Each item is independent */
3557 PL_curpm = newpm; /* Don't pop $1 et al till now */
3565 S_doparseform(pTHX_ SV *sv)
3568 register char *s = SvPV_force(sv, len);
3569 register char *send = s + len;
3570 register char *base;
3571 register I32 skipspaces = 0;
3574 bool postspace = FALSE;
3582 Perl_croak(aTHX_ "Null picture in formline");
3584 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3589 *fpc++ = FF_LINEMARK;
3590 noblank = repeat = FALSE;
3608 case ' ': case '\t':
3619 *fpc++ = FF_LITERAL;
3627 *fpc++ = skipspaces;
3631 *fpc++ = FF_NEWLINE;
3635 arg = fpc - linepc + 1;
3642 *fpc++ = FF_LINEMARK;
3643 noblank = repeat = FALSE;
3652 ischop = s[-1] == '^';
3658 arg = (s - base) - 1;
3660 *fpc++ = FF_LITERAL;
3669 *fpc++ = FF_LINEGLOB;
3671 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3672 arg = ischop ? 512 : 0;
3682 arg |= 256 + (s - f);
3684 *fpc++ = s - base; /* fieldsize for FETCH */
3685 *fpc++ = FF_DECIMAL;
3688 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3689 arg = ischop ? 512 : 0;
3691 s++; /* skip the '0' first */
3700 arg |= 256 + (s - f);
3702 *fpc++ = s - base; /* fieldsize for FETCH */
3703 *fpc++ = FF_0DECIMAL;
3708 bool ismore = FALSE;
3711 while (*++s == '>') ;
3712 prespace = FF_SPACE;
3714 else if (*s == '|') {
3715 while (*++s == '|') ;
3716 prespace = FF_HALFSPACE;
3721 while (*++s == '<') ;
3724 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3728 *fpc++ = s - base; /* fieldsize for FETCH */
3730 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3748 { /* need to jump to the next word */
3750 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3751 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3752 s = SvPVX(sv) + SvCUR(sv) + z;
3754 Copy(fops, s, arg, U16);
3756 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3761 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3763 * The original code was written in conjunction with BSD Computer Software
3764 * Research Group at University of California, Berkeley.
3766 * See also: "Optimistic Merge Sort" (SODA '92)
3768 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3770 * The code can be distributed under the same terms as Perl itself.
3775 #include <sys/types.h>
3780 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3781 #define Safefree(VAR) free(VAR)
3782 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3783 #endif /* TESTHARNESS */
3785 typedef char * aptr; /* pointer for arithmetic on sizes */
3786 typedef SV * gptr; /* pointers in our lists */
3788 /* Binary merge internal sort, with a few special mods
3789 ** for the special perl environment it now finds itself in.
3791 ** Things that were once options have been hotwired
3792 ** to values suitable for this use. In particular, we'll always
3793 ** initialize looking for natural runs, we'll always produce stable
3794 ** output, and we'll always do Peter McIlroy's binary merge.
3797 /* Pointer types for arithmetic and storage and convenience casts */
3799 #define APTR(P) ((aptr)(P))
3800 #define GPTP(P) ((gptr *)(P))
3801 #define GPPP(P) ((gptr **)(P))
3804 /* byte offset from pointer P to (larger) pointer Q */
3805 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3807 #define PSIZE sizeof(gptr)
3809 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3812 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3813 #define PNBYTE(N) ((N) << (PSHIFT))
3814 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3816 /* Leave optimization to compiler */
3817 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3818 #define PNBYTE(N) ((N) * (PSIZE))
3819 #define PINDEX(P, N) (GPTP(P) + (N))
3822 /* Pointer into other corresponding to pointer into this */
3823 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3825 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3828 /* Runs are identified by a pointer in the auxilliary list.
3829 ** The pointer is at the start of the list,
3830 ** and it points to the start of the next list.
3831 ** NEXT is used as an lvalue, too.
3834 #define NEXT(P) (*GPPP(P))
3837 /* PTHRESH is the minimum number of pairs with the same sense to justify
3838 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3839 ** not just elements, so PTHRESH == 8 means a run of 16.
3844 /* RTHRESH is the number of elements in a run that must compare low
3845 ** to the low element from the opposing run before we justify
3846 ** doing a binary rampup instead of single stepping.
3847 ** In random input, N in a row low should only happen with
3848 ** probability 2^(1-N), so we can risk that we are dealing
3849 ** with orderly input without paying much when we aren't.
3856 ** Overview of algorithm and variables.
3857 ** The array of elements at list1 will be organized into runs of length 2,
3858 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3859 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3861 ** Unless otherwise specified, pair pointers address the first of two elements.
3863 ** b and b+1 are a pair that compare with sense ``sense''.
3864 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3866 ** p2 parallels b in the list2 array, where runs are defined by
3869 ** t represents the ``top'' of the adjacent pairs that might extend
3870 ** the run beginning at b. Usually, t addresses a pair
3871 ** that compares with opposite sense from (b,b+1).
3872 ** However, it may also address a singleton element at the end of list1,
3873 ** or it may be equal to ``last'', the first element beyond list1.
3875 ** r addresses the Nth pair following b. If this would be beyond t,
3876 ** we back it off to t. Only when r is less than t do we consider the
3877 ** run long enough to consider checking.
3879 ** q addresses a pair such that the pairs at b through q already form a run.
3880 ** Often, q will equal b, indicating we only are sure of the pair itself.
3881 ** However, a search on the previous cycle may have revealed a longer run,
3882 ** so q may be greater than b.
3884 ** p is used to work back from a candidate r, trying to reach q,
3885 ** which would mean b through r would be a run. If we discover such a run,
3886 ** we start q at r and try to push it further towards t.
3887 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3888 ** In any event, after the check (if any), we have two main cases.
3890 ** 1) Short run. b <= q < p <= r <= t.
3891 ** b through q is a run (perhaps trivial)
3892 ** q through p are uninteresting pairs
3893 ** p through r is a run
3895 ** 2) Long run. b < r <= q < t.
3896 ** b through q is a run (of length >= 2 * PTHRESH)
3898 ** Note that degenerate cases are not only possible, but likely.
3899 ** For example, if the pair following b compares with opposite sense,
3900 ** then b == q < p == r == t.
3905 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3908 register gptr *b, *p, *q, *t, *p2;
3909 register gptr c, *last, *r;
3913 last = PINDEX(b, nmemb);
3914 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3915 for (p2 = list2; b < last; ) {
3916 /* We just started, or just reversed sense.
3917 ** Set t at end of pairs with the prevailing sense.
3919 for (p = b+2, t = p; ++p < last; t = ++p) {
3920 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3923 /* Having laid out the playing field, look for long runs */
3925 p = r = b + (2 * PTHRESH);
3926 if (r >= t) p = r = t; /* too short to care about */
3928 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3931 /* b through r is a (long) run.
3932 ** Extend it as far as possible.
3935 while (((p += 2) < t) &&
3936 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3937 r = p = q + 2; /* no simple pairs, no after-run */
3940 if (q > b) { /* run of greater than 2 at b */
3943 /* pick up singleton, if possible */
3945 ((t + 1) == last) &&
3946 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3947 savep = r = p = q = last;
3948 p2 = NEXT(p2) = p2 + (p - b);
3949 if (sense) while (b < --p) {
3956 while (q < p) { /* simple pairs */
3957 p2 = NEXT(p2) = p2 + 2;
3964 if (((b = p) == t) && ((t+1) == last)) {
3976 /* Overview of bmerge variables:
3978 ** list1 and list2 address the main and auxiliary arrays.
3979 ** They swap identities after each merge pass.
3980 ** Base points to the original list1, so we can tell if
3981 ** the pointers ended up where they belonged (or must be copied).
3983 ** When we are merging two lists, f1 and f2 are the next elements
3984 ** on the respective lists. l1 and l2 mark the end of the lists.
3985 ** tp2 is the current location in the merged list.
3987 ** p1 records where f1 started.
3988 ** After the merge, a new descriptor is built there.
3990 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3991 ** It is used to identify and delimit the runs.
3993 ** In the heat of determining where q, the greater of the f1/f2 elements,
3994 ** belongs in the other list, b, t and p, represent bottom, top and probe
3995 ** locations, respectively, in the other list.
3996 ** They make convenient temporary pointers in other places.
4000 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4004 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4005 gptr *aux, *list2, *p2, *last;
4009 if (nmemb <= 1) return; /* sorted trivially */
4010 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4012 dynprep(aTHX_ list1, list2, nmemb, cmp);
4013 last = PINDEX(list2, nmemb);
4014 while (NEXT(list2) != last) {
4015 /* More than one run remains. Do some merging to reduce runs. */
4017 for (tp2 = p2 = list2; p2 != last;) {
4018 /* The new first run begins where the old second list ended.
4019 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4023 f2 = l1 = POTHER(t, list2, list1);
4024 if (t != last) t = NEXT(t);
4025 l2 = POTHER(t, list2, list1);
4027 while (f1 < l1 && f2 < l2) {
4028 /* If head 1 is larger than head 2, find ALL the elements
4029 ** in list 2 strictly less than head1, write them all,
4030 ** then head 1. Then compare the new heads, and repeat,
4031 ** until one or both lists are exhausted.
4033 ** In all comparisons (after establishing
4034 ** which head to merge) the item to merge
4035 ** (at pointer q) is the first operand of
4036 ** the comparison. When we want to know
4037 ** if ``q is strictly less than the other'',
4039 ** cmp(q, other) < 0
4040 ** because stability demands that we treat equality
4041 ** as high when q comes from l2, and as low when
4042 ** q was from l1. So we ask the question by doing
4043 ** cmp(q, other) <= sense
4044 ** and make sense == 0 when equality should look low,
4045 ** and -1 when equality should look high.
4049 if (cmp(aTHX_ *f1, *f2) <= 0) {
4050 q = f2; b = f1; t = l1;
4053 q = f1; b = f2; t = l2;
4060 ** Leave t at something strictly
4061 ** greater than q (or at the end of the list),
4062 ** and b at something strictly less than q.
4064 for (i = 1, run = 0 ;;) {
4065 if ((p = PINDEX(b, i)) >= t) {
4067 if (((p = PINDEX(t, -1)) > b) &&
4068 (cmp(aTHX_ *q, *p) <= sense))
4072 } else if (cmp(aTHX_ *q, *p) <= sense) {
4076 if (++run >= RTHRESH) i += i;
4080 /* q is known to follow b and must be inserted before t.
4081 ** Increment b, so the range of possibilities is [b,t).
4082 ** Round binary split down, to favor early appearance.
4083 ** Adjust b and t until q belongs just before t.
4088 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4089 if (cmp(aTHX_ *q, *p) <= sense) {
4095 /* Copy all the strictly low elements */
4098 FROMTOUPTO(f2, tp2, t);
4101 FROMTOUPTO(f1, tp2, t);
4107 /* Run out remaining list */
4109 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4110 } else FROMTOUPTO(f1, tp2, l1);
4111 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4116 last = PINDEX(list2, nmemb);
4118 if (base == list2) {
4119 last = PINDEX(list1, nmemb);
4120 FROMTOUPTO(list1, list2, last);
4135 sortcv(pTHXo_ SV *a, SV *b)
4137 I32 oldsaveix = PL_savestack_ix;
4138 I32 oldscopeix = PL_scopestack_ix;
4140 GvSV(PL_firstgv) = a;
4141 GvSV(PL_secondgv) = b;
4142 PL_stack_sp = PL_stack_base;
4145 if (PL_stack_sp != PL_stack_base + 1)
4146 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4147 if (!SvNIOKp(*PL_stack_sp))
4148 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4149 result = SvIV(*PL_stack_sp);
4150 while (PL_scopestack_ix > oldscopeix) {
4153 leave_scope(oldsaveix);
4158 sortcv_stacked(pTHXo_ SV *a, SV *b)
4160 I32 oldsaveix = PL_savestack_ix;
4161 I32 oldscopeix = PL_scopestack_ix;
4166 av = (AV*)PL_curpad[0];
4168 av = GvAV(PL_defgv);
4171 if (AvMAX(av) < 1) {
4172 SV** ary = AvALLOC(av);
4173 if (AvARRAY(av) != ary) {
4174 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4175 SvPVX(av) = (char*)ary;
4177 if (AvMAX(av) < 1) {
4180 SvPVX(av) = (char*)ary;
4187 PL_stack_sp = PL_stack_base;
4190 if (PL_stack_sp != PL_stack_base + 1)
4191 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4192 if (!SvNIOKp(*PL_stack_sp))
4193 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4194 result = SvIV(*PL_stack_sp);
4195 while (PL_scopestack_ix > oldscopeix) {
4198 leave_scope(oldsaveix);
4203 sortcv_xsub(pTHXo_ SV *a, SV *b)
4206 I32 oldsaveix = PL_savestack_ix;
4207 I32 oldscopeix = PL_scopestack_ix;
4209 CV *cv=(CV*)PL_sortcop;
4217 (void)(*CvXSUB(cv))(aTHXo_ cv);
4218 if (PL_stack_sp != PL_stack_base + 1)
4219 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4220 if (!SvNIOKp(*PL_stack_sp))
4221 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4222 result = SvIV(*PL_stack_sp);
4223 while (PL_scopestack_ix > oldscopeix) {
4226 leave_scope(oldsaveix);
4232 sv_ncmp(pTHXo_ SV *a, SV *b)
4236 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4240 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4244 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4246 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4248 if (PL_amagic_generation) { \
4249 if (SvAMAGIC(left)||SvAMAGIC(right))\
4250 *svp = amagic_call(left, \
4258 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4261 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4266 I32 i = SvIVX(tmpsv);
4276 return sv_ncmp(aTHXo_ a, b);
4280 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4283 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4288 I32 i = SvIVX(tmpsv);
4298 return sv_i_ncmp(aTHXo_ a, b);
4302 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4305 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4310 I32 i = SvIVX(tmpsv);
4320 return sv_cmp(str1, str2);
4324 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4327 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4332 I32 i = SvIVX(tmpsv);
4342 return sv_cmp_locale(str1, str2);
4346 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4348 SV *datasv = FILTER_DATA(idx);
4349 int filter_has_file = IoLINES(datasv);
4350 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4351 SV *filter_state = (SV *)IoTOP_GV(datasv);
4352 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4355 /* I was having segfault trouble under Linux 2.2.5 after a
4356 parse error occured. (Had to hack around it with a test
4357 for PL_error_count == 0.) Solaris doesn't segfault --
4358 not sure where the trouble is yet. XXX */
4360 if (filter_has_file) {
4361 len = FILTER_READ(idx+1, buf_sv, maxlen);
4364 if (filter_sub && len >= 0) {
4375 PUSHs(sv_2mortal(newSViv(maxlen)));
4377 PUSHs(filter_state);
4380 count = call_sv(filter_sub, G_SCALAR);
4396 IoLINES(datasv) = 0;
4397 if (filter_child_proc) {
4398 SvREFCNT_dec(filter_child_proc);
4399 IoFMT_GV(datasv) = Nullgv;
4402 SvREFCNT_dec(filter_state);
4403 IoTOP_GV(datasv) = Nullgv;
4406 SvREFCNT_dec(filter_sub);
4407 IoBOTTOM_GV(datasv) = Nullgv;
4409 filter_del(run_user_filter);
4418 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4420 return sv_cmp_locale(str1, str2);
4424 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4426 return sv_cmp(str1, str2);
4429 #endif /* PERL_OBJECT */