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 STRLEN skip = UTF8SKIP(s);
571 if ( !((*t++ = *s++) & ~31) )
579 int ch = *t++ = *s++;
582 if ( !((*t++ = *s++) & ~31) )
591 while (*s && isSPACE(*s))
598 item = s = SvPV(sv, len);
600 item_is_utf = FALSE; /* XXX is this correct? */
612 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
613 sv_catpvn(PL_formtarget, item, itemsize);
614 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
615 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
620 /* If the field is marked with ^ and the value is undefined,
623 if ((arg & 512) && !SvOK(sv)) {
631 /* Formats aren't yet marked for locales, so assume "yes". */
633 STORE_NUMERIC_STANDARD_SET_LOCAL();
634 #if defined(USE_LONG_DOUBLE)
636 sprintf(t, "%#*.*" PERL_PRIfldbl,
637 (int) fieldsize, (int) arg & 255, value);
639 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
644 (int) fieldsize, (int) arg & 255, value);
647 (int) fieldsize, value);
650 RESTORE_NUMERIC_STANDARD();
656 /* If the field is marked with ^ and the value is undefined,
659 if ((arg & 512) && !SvOK(sv)) {
667 /* Formats aren't yet marked for locales, so assume "yes". */
669 STORE_NUMERIC_STANDARD_SET_LOCAL();
670 #if defined(USE_LONG_DOUBLE)
672 sprintf(t, "%#0*.*" PERL_PRIfldbl,
673 (int) fieldsize, (int) arg & 255, value);
674 /* is this legal? I don't have long doubles */
676 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
680 sprintf(t, "%#0*.*f",
681 (int) fieldsize, (int) arg & 255, value);
684 (int) fieldsize, value);
687 RESTORE_NUMERIC_STANDARD();
694 while (t-- > linemark && *t == ' ') ;
702 if (arg) { /* repeat until fields exhausted? */
704 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
705 lines += FmLINES(PL_formtarget);
708 if (strnEQ(linemark, linemark - arg, arg))
709 DIE(aTHX_ "Runaway format");
711 FmLINES(PL_formtarget) = lines;
713 RETURNOP(cLISTOP->op_first);
726 while (*s && isSPACE(*s) && s < send)
730 arg = fieldsize - itemsize;
737 if (strnEQ(s," ",3)) {
738 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
749 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
750 FmLINES(PL_formtarget) += lines;
762 if (PL_stack_base + *PL_markstack_ptr == SP) {
764 if (GIMME_V == G_SCALAR)
765 XPUSHs(sv_2mortal(newSViv(0)));
766 RETURNOP(PL_op->op_next->op_next);
768 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
769 pp_pushmark(); /* push dst */
770 pp_pushmark(); /* push src */
771 ENTER; /* enter outer scope */
774 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
776 ENTER; /* enter inner scope */
779 src = PL_stack_base[*PL_markstack_ptr];
784 if (PL_op->op_type == OP_MAPSTART)
785 pp_pushmark(); /* push top */
786 return ((LOGOP*)PL_op->op_next)->op_other;
791 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
797 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
803 /* first, move source pointer to the next item in the source list */
804 ++PL_markstack_ptr[-1];
806 /* if there are new items, push them into the destination list */
808 /* might need to make room back there first */
809 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
810 /* XXX this implementation is very pessimal because the stack
811 * is repeatedly extended for every set of items. Is possible
812 * to do this without any stack extension or copying at all
813 * by maintaining a separate list over which the map iterates
814 * (like foreach does). --gsar */
816 /* everything in the stack after the destination list moves
817 * towards the end the stack by the amount of room needed */
818 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
820 /* items to shift up (accounting for the moved source pointer) */
821 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
823 /* This optimization is by Ben Tilly and it does
824 * things differently from what Sarathy (gsar)
825 * is describing. The downside of this optimization is
826 * that leaves "holes" (uninitialized and hopefully unused areas)
827 * to the Perl stack, but on the other hand this
828 * shouldn't be a problem. If Sarathy's idea gets
829 * implemented, this optimization should become
830 * irrelevant. --jhi */
832 shift = count; /* Avoid shifting too often --Ben Tilly */
837 PL_markstack_ptr[-1] += shift;
838 *PL_markstack_ptr += shift;
842 /* copy the new items down to the destination list */
843 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
845 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
847 LEAVE; /* exit inner scope */
850 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
853 (void)POPMARK; /* pop top */
854 LEAVE; /* exit outer scope */
855 (void)POPMARK; /* pop src */
856 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
857 (void)POPMARK; /* pop dst */
858 SP = PL_stack_base + POPMARK; /* pop original mark */
859 if (gimme == G_SCALAR) {
863 else if (gimme == G_ARRAY)
870 ENTER; /* enter inner scope */
873 /* set $_ to the new source item */
874 src = PL_stack_base[PL_markstack_ptr[-1]];
878 RETURNOP(cLOGOP->op_other);
884 dSP; dMARK; dORIGMARK;
886 SV **myorigmark = ORIGMARK;
892 OP* nextop = PL_op->op_next;
894 bool hasargs = FALSE;
897 if (gimme != G_ARRAY) {
903 SAVEVPTR(PL_sortcop);
904 if (PL_op->op_flags & OPf_STACKED) {
905 if (PL_op->op_flags & OPf_SPECIAL) {
906 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
907 kid = kUNOP->op_first; /* pass rv2gv */
908 kid = kUNOP->op_first; /* pass leave */
909 PL_sortcop = kid->op_next;
910 stash = CopSTASH(PL_curcop);
913 cv = sv_2cv(*++MARK, &stash, &gv, 0);
914 if (cv && SvPOK(cv)) {
916 char *proto = SvPV((SV*)cv, n_a);
917 if (proto && strEQ(proto, "$$")) {
921 if (!(cv && CvROOT(cv))) {
922 if (cv && CvXSUB(cv)) {
926 SV *tmpstr = sv_newmortal();
927 gv_efullname3(tmpstr, gv, Nullch);
928 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
932 DIE(aTHX_ "Undefined subroutine in sort");
937 PL_sortcop = (OP*)cv;
939 PL_sortcop = CvSTART(cv);
940 SAVEVPTR(CvROOT(cv)->op_ppaddr);
941 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
944 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
950 stash = CopSTASH(PL_curcop);
954 while (MARK < SP) { /* This may or may not shift down one here. */
956 if ((*up = *++MARK)) { /* Weed out nulls. */
958 if (!PL_sortcop && !SvPOK(*up)) {
963 (void)sv_2pv(*up, &n_a);
968 max = --up - myorigmark;
973 bool oldcatch = CATCH_GET;
979 PUSHSTACKi(PERLSI_SORT);
980 if (!hasargs && !is_xsub) {
981 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
982 SAVESPTR(PL_firstgv);
983 SAVESPTR(PL_secondgv);
984 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
985 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
986 PL_sortstash = stash;
989 sv_lock((SV *)PL_firstgv);
990 sv_lock((SV *)PL_secondgv);
992 SAVESPTR(GvSV(PL_firstgv));
993 SAVESPTR(GvSV(PL_secondgv));
996 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
997 if (!(PL_op->op_flags & OPf_SPECIAL)) {
998 cx->cx_type = CXt_SUB;
999 cx->blk_gimme = G_SCALAR;
1002 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
1004 PL_sortcxix = cxstack_ix;
1006 if (hasargs && !is_xsub) {
1007 /* This is mostly copied from pp_entersub */
1008 AV *av = (AV*)PL_curpad[0];
1011 cx->blk_sub.savearray = GvAV(PL_defgv);
1012 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1013 #endif /* USE_THREADS */
1014 cx->blk_sub.oldcurpad = PL_curpad;
1015 cx->blk_sub.argarray = av;
1017 qsortsv((myorigmark+1), max,
1018 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
1020 POPBLOCK(cx,PL_curpm);
1021 PL_stack_sp = newsp;
1023 CATCH_SET(oldcatch);
1028 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
1029 qsortsv(ORIGMARK+1, max,
1030 (PL_op->op_private & OPpSORT_NUMERIC)
1031 ? ( (PL_op->op_private & OPpSORT_INTEGER)
1032 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
1033 : ( overloading ? amagic_ncmp : sv_ncmp))
1034 : ( (PL_op->op_private & OPpLOCALE)
1037 : sv_cmp_locale_static)
1038 : ( overloading ? amagic_cmp : sv_cmp_static)));
1039 if (PL_op->op_private & OPpSORT_REVERSE) {
1040 SV **p = ORIGMARK+1;
1041 SV **q = ORIGMARK+max;
1051 PL_stack_sp = ORIGMARK + max;
1059 if (GIMME == G_ARRAY)
1061 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1062 return cLOGOP->op_other;
1071 if (GIMME == G_ARRAY) {
1072 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1076 SV *targ = PAD_SV(PL_op->op_targ);
1079 if (PL_op->op_private & OPpFLIP_LINENUM) {
1081 flip = PL_last_in_gv
1082 && (gp_io = GvIO(PL_last_in_gv))
1083 && SvIV(sv) == (IV)IoLINES(gp_io);
1088 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1089 if (PL_op->op_flags & OPf_SPECIAL) {
1097 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1110 if (GIMME == G_ARRAY) {
1116 if (SvGMAGICAL(left))
1118 if (SvGMAGICAL(right))
1121 if (SvNIOKp(left) || !SvPOKp(left) ||
1122 SvNIOKp(right) || !SvPOKp(right) ||
1123 (looks_like_number(left) && *SvPVX(left) != '0' &&
1124 looks_like_number(right) && *SvPVX(right) != '0'))
1126 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1127 DIE(aTHX_ "Range iterator outside integer range");
1138 sv = sv_2mortal(newSViv(i++));
1143 SV *final = sv_mortalcopy(right);
1145 char *tmps = SvPV(final, len);
1147 sv = sv_mortalcopy(left);
1149 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1151 if (strEQ(SvPVX(sv),tmps))
1153 sv = sv_2mortal(newSVsv(sv));
1160 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1162 if ((PL_op->op_private & OPpFLIP_LINENUM)
1163 ? (GvIO(PL_last_in_gv)
1164 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1166 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1167 sv_catpv(targ, "E0");
1178 S_dopoptolabel(pTHX_ char *label)
1181 register PERL_CONTEXT *cx;
1183 for (i = cxstack_ix; i >= 0; i--) {
1185 switch (CxTYPE(cx)) {
1187 if (ckWARN(WARN_EXITING))
1188 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1189 PL_op_name[PL_op->op_type]);
1192 if (ckWARN(WARN_EXITING))
1193 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1194 PL_op_name[PL_op->op_type]);
1197 if (ckWARN(WARN_EXITING))
1198 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1199 PL_op_name[PL_op->op_type]);
1202 if (ckWARN(WARN_EXITING))
1203 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1204 PL_op_name[PL_op->op_type]);
1207 if (ckWARN(WARN_EXITING))
1208 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1209 PL_op_name[PL_op->op_type]);
1212 if (!cx->blk_loop.label ||
1213 strNE(label, cx->blk_loop.label) ) {
1214 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1215 (long)i, cx->blk_loop.label));
1218 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1226 Perl_dowantarray(pTHX)
1228 I32 gimme = block_gimme();
1229 return (gimme == G_VOID) ? G_SCALAR : gimme;
1233 Perl_block_gimme(pTHX)
1237 cxix = dopoptosub(cxstack_ix);
1241 switch (cxstack[cxix].blk_gimme) {
1249 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1256 Perl_is_lvalue_sub(pTHX)
1260 cxix = dopoptosub(cxstack_ix);
1261 assert(cxix >= 0); /* We should only be called from inside subs */
1263 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1264 return cxstack[cxix].blk_sub.lval;
1270 S_dopoptosub(pTHX_ I32 startingblock)
1272 return dopoptosub_at(cxstack, startingblock);
1276 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1279 register PERL_CONTEXT *cx;
1280 for (i = startingblock; i >= 0; i--) {
1282 switch (CxTYPE(cx)) {
1288 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1296 S_dopoptoeval(pTHX_ I32 startingblock)
1299 register PERL_CONTEXT *cx;
1300 for (i = startingblock; i >= 0; i--) {
1302 switch (CxTYPE(cx)) {
1306 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1314 S_dopoptoloop(pTHX_ I32 startingblock)
1317 register PERL_CONTEXT *cx;
1318 for (i = startingblock; i >= 0; i--) {
1320 switch (CxTYPE(cx)) {
1322 if (ckWARN(WARN_EXITING))
1323 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1324 PL_op_name[PL_op->op_type]);
1327 if (ckWARN(WARN_EXITING))
1328 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1329 PL_op_name[PL_op->op_type]);
1332 if (ckWARN(WARN_EXITING))
1333 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1334 PL_op_name[PL_op->op_type]);
1337 if (ckWARN(WARN_EXITING))
1338 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1339 PL_op_name[PL_op->op_type]);
1342 if (ckWARN(WARN_EXITING))
1343 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1344 PL_op_name[PL_op->op_type]);
1347 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1355 Perl_dounwind(pTHX_ I32 cxix)
1357 register PERL_CONTEXT *cx;
1360 while (cxstack_ix > cxix) {
1362 cx = &cxstack[cxstack_ix];
1363 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1364 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1365 /* Note: we don't need to restore the base context info till the end. */
1366 switch (CxTYPE(cx)) {
1369 continue; /* not break */
1391 Perl_qerror(pTHX_ SV *err)
1394 sv_catsv(ERRSV, err);
1396 sv_catsv(PL_errors, err);
1398 Perl_warn(aTHX_ "%"SVf, err);
1403 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1408 register PERL_CONTEXT *cx;
1413 if (PL_in_eval & EVAL_KEEPERR) {
1414 static char prefix[] = "\t(in cleanup) ";
1419 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1422 if (*e != *message || strNE(e,message))
1426 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1427 sv_catpvn(err, prefix, sizeof(prefix)-1);
1428 sv_catpvn(err, message, msglen);
1429 if (ckWARN(WARN_MISC)) {
1430 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1431 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1436 sv_setpvn(ERRSV, message, msglen);
1437 if (PL_hints & HINT_UTF8)
1444 message = SvPVx(ERRSV, msglen);
1446 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1447 && PL_curstackinfo->si_prev)
1456 if (cxix < cxstack_ix)
1459 POPBLOCK(cx,PL_curpm);
1460 if (CxTYPE(cx) != CXt_EVAL) {
1461 PerlIO_write(Perl_error_log, "panic: die ", 11);
1462 PerlIO_write(Perl_error_log, message, msglen);
1467 if (gimme == G_SCALAR)
1468 *++newsp = &PL_sv_undef;
1469 PL_stack_sp = newsp;
1473 /* LEAVE could clobber PL_curcop (see save_re_context())
1474 * XXX it might be better to find a way to avoid messing with
1475 * PL_curcop in save_re_context() instead, but this is a more
1476 * minimal fix --GSAR */
1477 PL_curcop = cx->blk_oldcop;
1479 if (optype == OP_REQUIRE) {
1480 char* msg = SvPVx(ERRSV, n_a);
1481 DIE(aTHX_ "%sCompilation failed in require",
1482 *msg ? msg : "Unknown error\n");
1484 return pop_return();
1488 message = SvPVx(ERRSV, msglen);
1491 /* SFIO can really mess with your errno */
1494 PerlIO *serr = Perl_error_log;
1496 PerlIO_write(serr, message, msglen);
1497 (void)PerlIO_flush(serr);
1510 if (SvTRUE(left) != SvTRUE(right))
1522 RETURNOP(cLOGOP->op_other);
1531 RETURNOP(cLOGOP->op_other);
1537 register I32 cxix = dopoptosub(cxstack_ix);
1538 register PERL_CONTEXT *cx;
1539 register PERL_CONTEXT *ccstack = cxstack;
1540 PERL_SI *top_si = PL_curstackinfo;
1551 /* we may be in a higher stacklevel, so dig down deeper */
1552 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1553 top_si = top_si->si_prev;
1554 ccstack = top_si->si_cxstack;
1555 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1558 if (GIMME != G_ARRAY)
1562 if (PL_DBsub && cxix >= 0 &&
1563 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1567 cxix = dopoptosub_at(ccstack, cxix - 1);
1570 cx = &ccstack[cxix];
1571 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1572 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1573 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1574 field below is defined for any cx. */
1575 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1576 cx = &ccstack[dbcxix];
1579 stashname = CopSTASHPV(cx->blk_oldcop);
1580 if (GIMME != G_ARRAY) {
1582 PUSHs(&PL_sv_undef);
1585 sv_setpv(TARG, stashname);
1592 PUSHs(&PL_sv_undef);
1594 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1595 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1596 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1599 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1600 /* So is ccstack[dbcxix]. */
1602 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1603 PUSHs(sv_2mortal(sv));
1604 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1607 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1608 PUSHs(sv_2mortal(newSViv(0)));
1610 gimme = (I32)cx->blk_gimme;
1611 if (gimme == G_VOID)
1612 PUSHs(&PL_sv_undef);
1614 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1615 if (CxTYPE(cx) == CXt_EVAL) {
1617 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1618 PUSHs(cx->blk_eval.cur_text);
1622 else if (cx->blk_eval.old_namesv) {
1623 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1626 /* eval BLOCK (try blocks have old_namesv == 0) */
1628 PUSHs(&PL_sv_undef);
1629 PUSHs(&PL_sv_undef);
1633 PUSHs(&PL_sv_undef);
1634 PUSHs(&PL_sv_undef);
1636 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1637 && CopSTASH_eq(PL_curcop, PL_debstash))
1639 AV *ary = cx->blk_sub.argarray;
1640 int off = AvARRAY(ary) - AvALLOC(ary);
1644 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1647 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1650 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1651 av_extend(PL_dbargs, AvFILLp(ary) + off);
1652 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1653 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1655 /* XXX only hints propagated via op_private are currently
1656 * visible (others are not easily accessible, since they
1657 * use the global PL_hints) */
1658 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1659 HINT_PRIVATE_MASK)));
1662 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1664 if (old_warnings == pWARN_NONE ||
1665 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1666 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1667 else if (old_warnings == pWARN_ALL ||
1668 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1669 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1671 mask = newSVsv(old_warnings);
1672 PUSHs(sv_2mortal(mask));
1687 sv_reset(tmps, CopSTASH(PL_curcop));
1699 PL_curcop = (COP*)PL_op;
1700 TAINT_NOT; /* Each statement is presumed innocent */
1701 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1704 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1708 register PERL_CONTEXT *cx;
1709 I32 gimme = G_ARRAY;
1716 DIE(aTHX_ "No DB::DB routine defined");
1718 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1719 /* don't do recursive DB::DB call */
1731 push_return(PL_op->op_next);
1732 PUSHBLOCK(cx, CXt_SUB, SP);
1735 (void)SvREFCNT_inc(cv);
1736 SAVEVPTR(PL_curpad);
1737 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1738 RETURNOP(CvSTART(cv));
1752 register PERL_CONTEXT *cx;
1753 I32 gimme = GIMME_V;
1755 U32 cxtype = CXt_LOOP;
1764 if (PL_op->op_flags & OPf_SPECIAL) {
1765 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1766 SAVEGENERICSV(*svp);
1770 #endif /* USE_THREADS */
1771 if (PL_op->op_targ) {
1772 #ifndef USE_ITHREADS
1773 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1776 SAVEPADSV(PL_op->op_targ);
1777 iterdata = (void*)PL_op->op_targ;
1778 cxtype |= CXp_PADVAR;
1783 svp = &GvSV(gv); /* symbol table variable */
1784 SAVEGENERICSV(*svp);
1787 iterdata = (void*)gv;
1793 PUSHBLOCK(cx, cxtype, SP);
1795 PUSHLOOP(cx, iterdata, MARK);
1797 PUSHLOOP(cx, svp, MARK);
1799 if (PL_op->op_flags & OPf_STACKED) {
1800 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1801 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1803 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1804 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1805 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1806 looks_like_number((SV*)cx->blk_loop.iterary) &&
1807 *SvPVX(cx->blk_loop.iterary) != '0'))
1809 if (SvNV(sv) < IV_MIN ||
1810 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1811 DIE(aTHX_ "Range iterator outside integer range");
1812 cx->blk_loop.iterix = SvIV(sv);
1813 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1816 cx->blk_loop.iterlval = newSVsv(sv);
1820 cx->blk_loop.iterary = PL_curstack;
1821 AvFILLp(PL_curstack) = SP - PL_stack_base;
1822 cx->blk_loop.iterix = MARK - PL_stack_base;
1831 register PERL_CONTEXT *cx;
1832 I32 gimme = GIMME_V;
1838 PUSHBLOCK(cx, CXt_LOOP, SP);
1839 PUSHLOOP(cx, 0, SP);
1847 register PERL_CONTEXT *cx;
1855 newsp = PL_stack_base + cx->blk_loop.resetsp;
1858 if (gimme == G_VOID)
1860 else if (gimme == G_SCALAR) {
1862 *++newsp = sv_mortalcopy(*SP);
1864 *++newsp = &PL_sv_undef;
1868 *++newsp = sv_mortalcopy(*++mark);
1869 TAINT_NOT; /* Each item is independent */
1875 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1876 PL_curpm = newpm; /* ... and pop $1 et al */
1888 register PERL_CONTEXT *cx;
1889 bool popsub2 = FALSE;
1890 bool clear_errsv = FALSE;
1897 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1898 if (cxstack_ix == PL_sortcxix
1899 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1901 if (cxstack_ix > PL_sortcxix)
1902 dounwind(PL_sortcxix);
1903 AvARRAY(PL_curstack)[1] = *SP;
1904 PL_stack_sp = PL_stack_base + 1;
1909 cxix = dopoptosub(cxstack_ix);
1911 DIE(aTHX_ "Can't return outside a subroutine");
1912 if (cxix < cxstack_ix)
1916 switch (CxTYPE(cx)) {
1921 if (!(PL_in_eval & EVAL_KEEPERR))
1927 if (optype == OP_REQUIRE &&
1928 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1930 /* Unassume the success we assumed earlier. */
1931 SV *nsv = cx->blk_eval.old_namesv;
1932 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1933 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1940 DIE(aTHX_ "panic: return");
1944 if (gimme == G_SCALAR) {
1947 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1949 *++newsp = SvREFCNT_inc(*SP);
1954 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1956 *++newsp = sv_mortalcopy(sv);
1961 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1964 *++newsp = sv_mortalcopy(*SP);
1967 *++newsp = &PL_sv_undef;
1969 else if (gimme == G_ARRAY) {
1970 while (++MARK <= SP) {
1971 *++newsp = (popsub2 && SvTEMP(*MARK))
1972 ? *MARK : sv_mortalcopy(*MARK);
1973 TAINT_NOT; /* Each item is independent */
1976 PL_stack_sp = newsp;
1978 /* Stack values are safe: */
1980 POPSUB(cx,sv); /* release CV and @_ ... */
1984 PL_curpm = newpm; /* ... and pop $1 et al */
1990 return pop_return();
1997 register PERL_CONTEXT *cx;
2007 if (PL_op->op_flags & OPf_SPECIAL) {
2008 cxix = dopoptoloop(cxstack_ix);
2010 DIE(aTHX_ "Can't \"last\" outside a loop block");
2013 cxix = dopoptolabel(cPVOP->op_pv);
2015 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2017 if (cxix < cxstack_ix)
2022 switch (CxTYPE(cx)) {
2025 newsp = PL_stack_base + cx->blk_loop.resetsp;
2026 nextop = cx->blk_loop.last_op->op_next;
2030 nextop = pop_return();
2034 nextop = pop_return();
2038 nextop = pop_return();
2041 DIE(aTHX_ "panic: last");
2045 if (gimme == G_SCALAR) {
2047 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2048 ? *SP : sv_mortalcopy(*SP);
2050 *++newsp = &PL_sv_undef;
2052 else if (gimme == G_ARRAY) {
2053 while (++MARK <= SP) {
2054 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2055 ? *MARK : sv_mortalcopy(*MARK);
2056 TAINT_NOT; /* Each item is independent */
2062 /* Stack values are safe: */
2065 POPLOOP(cx); /* release loop vars ... */
2069 POPSUB(cx,sv); /* release CV and @_ ... */
2072 PL_curpm = newpm; /* ... and pop $1 et al */
2082 register PERL_CONTEXT *cx;
2085 if (PL_op->op_flags & OPf_SPECIAL) {
2086 cxix = dopoptoloop(cxstack_ix);
2088 DIE(aTHX_ "Can't \"next\" outside a loop block");
2091 cxix = dopoptolabel(cPVOP->op_pv);
2093 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2095 if (cxix < cxstack_ix)
2098 /* clear off anything above the scope we're re-entering, but
2099 * save the rest until after a possible continue block */
2100 inner = PL_scopestack_ix;
2102 if (PL_scopestack_ix < inner)
2103 leave_scope(PL_scopestack[PL_scopestack_ix]);
2104 return cx->blk_loop.next_op;
2110 register PERL_CONTEXT *cx;
2113 if (PL_op->op_flags & OPf_SPECIAL) {
2114 cxix = dopoptoloop(cxstack_ix);
2116 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2119 cxix = dopoptolabel(cPVOP->op_pv);
2121 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2123 if (cxix < cxstack_ix)
2127 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2128 LEAVE_SCOPE(oldsave);
2129 return cx->blk_loop.redo_op;
2133 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2137 static char too_deep[] = "Target of goto is too deeply nested";
2140 Perl_croak(aTHX_ too_deep);
2141 if (o->op_type == OP_LEAVE ||
2142 o->op_type == OP_SCOPE ||
2143 o->op_type == OP_LEAVELOOP ||
2144 o->op_type == OP_LEAVETRY)
2146 *ops++ = cUNOPo->op_first;
2148 Perl_croak(aTHX_ too_deep);
2151 if (o->op_flags & OPf_KIDS) {
2152 /* First try all the kids at this level, since that's likeliest. */
2153 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2154 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2155 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2159 if (kid == PL_lastgotoprobe)
2161 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2163 (ops[-1]->op_type != OP_NEXTSTATE &&
2164 ops[-1]->op_type != OP_DBSTATE)))
2166 if ((o = dofindlabel(kid, label, ops, oplimit)))
2185 register PERL_CONTEXT *cx;
2186 #define GOTO_DEPTH 64
2187 OP *enterops[GOTO_DEPTH];
2189 int do_dump = (PL_op->op_type == OP_DUMP);
2190 static char must_have_label[] = "goto must have label";
2193 if (PL_op->op_flags & OPf_STACKED) {
2197 /* This egregious kludge implements goto &subroutine */
2198 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2200 register PERL_CONTEXT *cx;
2201 CV* cv = (CV*)SvRV(sv);
2207 if (!CvROOT(cv) && !CvXSUB(cv)) {
2212 /* autoloaded stub? */
2213 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2215 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2216 GvNAMELEN(gv), FALSE);
2217 if (autogv && (cv = GvCV(autogv)))
2219 tmpstr = sv_newmortal();
2220 gv_efullname3(tmpstr, gv, Nullch);
2221 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2223 DIE(aTHX_ "Goto undefined subroutine");
2226 /* First do some returnish stuff. */
2227 cxix = dopoptosub(cxstack_ix);
2229 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2230 if (cxix < cxstack_ix)
2234 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2236 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2237 /* put @_ back onto stack */
2238 AV* av = cx->blk_sub.argarray;
2240 items = AvFILLp(av) + 1;
2242 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2243 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2244 PL_stack_sp += items;
2246 SvREFCNT_dec(GvAV(PL_defgv));
2247 GvAV(PL_defgv) = cx->blk_sub.savearray;
2248 #endif /* USE_THREADS */
2249 /* abandon @_ if it got reified */
2251 (void)sv_2mortal((SV*)av); /* delay until return */
2253 av_extend(av, items-1);
2254 AvFLAGS(av) = AVf_REIFY;
2255 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2258 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2261 av = (AV*)PL_curpad[0];
2263 av = GvAV(PL_defgv);
2265 items = AvFILLp(av) + 1;
2267 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2268 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2269 PL_stack_sp += items;
2271 if (CxTYPE(cx) == CXt_SUB &&
2272 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2273 SvREFCNT_dec(cx->blk_sub.cv);
2274 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2275 LEAVE_SCOPE(oldsave);
2277 /* Now do some callish stuff. */
2280 #ifdef PERL_XSUB_OLDSTYLE
2281 if (CvOLDSTYLE(cv)) {
2282 I32 (*fp3)(int,int,int);
2287 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2288 items = (*fp3)(CvXSUBANY(cv).any_i32,
2289 mark - PL_stack_base + 1,
2291 SP = PL_stack_base + items;
2294 #endif /* PERL_XSUB_OLDSTYLE */
2299 PL_stack_sp--; /* There is no cv arg. */
2300 /* Push a mark for the start of arglist */
2302 (void)(*CvXSUB(cv))(aTHXo_ cv);
2303 /* Pop the current context like a decent sub should */
2304 POPBLOCK(cx, PL_curpm);
2305 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2308 return pop_return();
2311 AV* padlist = CvPADLIST(cv);
2312 SV** svp = AvARRAY(padlist);
2313 if (CxTYPE(cx) == CXt_EVAL) {
2314 PL_in_eval = cx->blk_eval.old_in_eval;
2315 PL_eval_root = cx->blk_eval.old_eval_root;
2316 cx->cx_type = CXt_SUB;
2317 cx->blk_sub.hasargs = 0;
2319 cx->blk_sub.cv = cv;
2320 cx->blk_sub.olddepth = CvDEPTH(cv);
2322 if (CvDEPTH(cv) < 2)
2323 (void)SvREFCNT_inc(cv);
2324 else { /* save temporaries on recursion? */
2325 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2326 sub_crush_depth(cv);
2327 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2328 AV *newpad = newAV();
2329 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2330 I32 ix = AvFILLp((AV*)svp[1]);
2331 I32 names_fill = AvFILLp((AV*)svp[0]);
2332 svp = AvARRAY(svp[0]);
2333 for ( ;ix > 0; ix--) {
2334 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2335 char *name = SvPVX(svp[ix]);
2336 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2339 /* outer lexical or anon code */
2340 av_store(newpad, ix,
2341 SvREFCNT_inc(oldpad[ix]) );
2343 else { /* our own lexical */
2345 av_store(newpad, ix, sv = (SV*)newAV());
2346 else if (*name == '%')
2347 av_store(newpad, ix, sv = (SV*)newHV());
2349 av_store(newpad, ix, sv = NEWSV(0,0));
2353 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2354 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2357 av_store(newpad, ix, sv = NEWSV(0,0));
2361 if (cx->blk_sub.hasargs) {
2364 av_store(newpad, 0, (SV*)av);
2365 AvFLAGS(av) = AVf_REIFY;
2367 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2368 AvFILLp(padlist) = CvDEPTH(cv);
2369 svp = AvARRAY(padlist);
2373 if (!cx->blk_sub.hasargs) {
2374 AV* av = (AV*)PL_curpad[0];
2376 items = AvFILLp(av) + 1;
2378 /* Mark is at the end of the stack. */
2380 Copy(AvARRAY(av), SP + 1, items, SV*);
2385 #endif /* USE_THREADS */
2386 SAVEVPTR(PL_curpad);
2387 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2389 if (cx->blk_sub.hasargs)
2390 #endif /* USE_THREADS */
2392 AV* av = (AV*)PL_curpad[0];
2396 cx->blk_sub.savearray = GvAV(PL_defgv);
2397 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2398 #endif /* USE_THREADS */
2399 cx->blk_sub.oldcurpad = PL_curpad;
2400 cx->blk_sub.argarray = av;
2403 if (items >= AvMAX(av) + 1) {
2405 if (AvARRAY(av) != ary) {
2406 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407 SvPVX(av) = (char*)ary;
2409 if (items >= AvMAX(av) + 1) {
2410 AvMAX(av) = items - 1;
2411 Renew(ary,items+1,SV*);
2413 SvPVX(av) = (char*)ary;
2416 Copy(mark,AvARRAY(av),items,SV*);
2417 AvFILLp(av) = items - 1;
2418 assert(!AvREAL(av));
2425 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2427 * We do not care about using sv to call CV;
2428 * it's for informational purposes only.
2430 SV *sv = GvSV(PL_DBsub);
2433 if (PERLDB_SUB_NN) {
2434 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2437 gv_efullname3(sv, CvGV(cv), Nullch);
2440 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2441 PUSHMARK( PL_stack_sp );
2442 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2446 RETURNOP(CvSTART(cv));
2450 label = SvPV(sv,n_a);
2451 if (!(do_dump || *label))
2452 DIE(aTHX_ must_have_label);
2455 else if (PL_op->op_flags & OPf_SPECIAL) {
2457 DIE(aTHX_ must_have_label);
2460 label = cPVOP->op_pv;
2462 if (label && *label) {
2464 bool leaving_eval = FALSE;
2465 PERL_CONTEXT *last_eval_cx = 0;
2469 PL_lastgotoprobe = 0;
2471 for (ix = cxstack_ix; ix >= 0; ix--) {
2473 switch (CxTYPE(cx)) {
2475 leaving_eval = TRUE;
2476 if (CxREALEVAL(cx)) {
2477 gotoprobe = (last_eval_cx ?
2478 last_eval_cx->blk_eval.old_eval_root :
2483 /* else fall through */
2485 gotoprobe = cx->blk_oldcop->op_sibling;
2491 gotoprobe = cx->blk_oldcop->op_sibling;
2493 gotoprobe = PL_main_root;
2496 if (CvDEPTH(cx->blk_sub.cv)) {
2497 gotoprobe = CvROOT(cx->blk_sub.cv);
2503 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2506 DIE(aTHX_ "panic: goto");
2507 gotoprobe = PL_main_root;
2511 retop = dofindlabel(gotoprobe, label,
2512 enterops, enterops + GOTO_DEPTH);
2516 PL_lastgotoprobe = gotoprobe;
2519 DIE(aTHX_ "Can't find label %s", label);
2521 /* if we're leaving an eval, check before we pop any frames
2522 that we're not going to punt, otherwise the error
2525 if (leaving_eval && *enterops && enterops[1]) {
2527 for (i = 1; enterops[i]; i++)
2528 if (enterops[i]->op_type == OP_ENTERITER)
2529 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2532 /* pop unwanted frames */
2534 if (ix < cxstack_ix) {
2541 oldsave = PL_scopestack[PL_scopestack_ix];
2542 LEAVE_SCOPE(oldsave);
2545 /* push wanted frames */
2547 if (*enterops && enterops[1]) {
2549 for (ix = 1; enterops[ix]; ix++) {
2550 PL_op = enterops[ix];
2551 /* Eventually we may want to stack the needed arguments
2552 * for each op. For now, we punt on the hard ones. */
2553 if (PL_op->op_type == OP_ENTERITER)
2554 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2555 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2563 if (!retop) retop = PL_main_start;
2565 PL_restartop = retop;
2566 PL_do_undump = TRUE;
2570 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2571 PL_do_undump = FALSE;
2587 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2591 PL_exit_flags |= PERL_EXIT_EXPECTED;
2593 PUSHs(&PL_sv_undef);
2601 NV value = SvNVx(GvSV(cCOP->cop_gv));
2602 register I32 match = I_32(value);
2605 if (((NV)match) > value)
2606 --match; /* was fractional--truncate other way */
2608 match -= cCOP->uop.scop.scop_offset;
2611 else if (match > cCOP->uop.scop.scop_max)
2612 match = cCOP->uop.scop.scop_max;
2613 PL_op = cCOP->uop.scop.scop_next[match];
2623 PL_op = PL_op->op_next; /* can't assume anything */
2626 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2627 match -= cCOP->uop.scop.scop_offset;
2630 else if (match > cCOP->uop.scop.scop_max)
2631 match = cCOP->uop.scop.scop_max;
2632 PL_op = cCOP->uop.scop.scop_next[match];
2641 S_save_lines(pTHX_ AV *array, SV *sv)
2643 register char *s = SvPVX(sv);
2644 register char *send = SvPVX(sv) + SvCUR(sv);
2646 register I32 line = 1;
2648 while (s && s < send) {
2649 SV *tmpstr = NEWSV(85,0);
2651 sv_upgrade(tmpstr, SVt_PVMG);
2652 t = strchr(s, '\n');
2658 sv_setpvn(tmpstr, s, t - s);
2659 av_store(array, line++, tmpstr);
2664 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2666 S_docatch_body(pTHX_ va_list args)
2668 return docatch_body();
2673 S_docatch_body(pTHX)
2680 S_docatch(pTHX_ OP *o)
2684 volatile PERL_SI *cursi = PL_curstackinfo;
2688 assert(CATCH_GET == TRUE);
2691 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2693 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2699 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2705 if (PL_restartop && cursi == PL_curstackinfo) {
2706 PL_op = PL_restartop;
2723 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2724 /* sv Text to convert to OP tree. */
2725 /* startop op_free() this to undo. */
2726 /* code Short string id of the caller. */
2728 dSP; /* Make POPBLOCK work. */
2731 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2735 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2736 char *tmpbuf = tbuf;
2742 /* switch to eval mode */
2744 if (PL_curcop == &PL_compiling) {
2745 SAVECOPSTASH_FREE(&PL_compiling);
2746 CopSTASH_set(&PL_compiling, PL_curstash);
2748 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2749 SV *sv = sv_newmortal();
2750 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2751 code, (unsigned long)++PL_evalseq,
2752 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2756 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2757 SAVECOPFILE_FREE(&PL_compiling);
2758 CopFILE_set(&PL_compiling, tmpbuf+2);
2759 SAVECOPLINE(&PL_compiling);
2760 CopLINE_set(&PL_compiling, 1);
2761 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2762 deleting the eval's FILEGV from the stash before gv_check() runs
2763 (i.e. before run-time proper). To work around the coredump that
2764 ensues, we always turn GvMULTI_on for any globals that were
2765 introduced within evals. See force_ident(). GSAR 96-10-12 */
2766 safestr = savepv(tmpbuf);
2767 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2769 #ifdef OP_IN_REGISTER
2774 PL_hints &= HINT_UTF8;
2777 PL_op->op_type = OP_ENTEREVAL;
2778 PL_op->op_flags = 0; /* Avoid uninit warning. */
2779 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2780 PUSHEVAL(cx, 0, Nullgv);
2781 rop = doeval(G_SCALAR, startop);
2782 POPBLOCK(cx,PL_curpm);
2785 (*startop)->op_type = OP_NULL;
2786 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2788 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2790 if (PL_curcop == &PL_compiling)
2791 PL_compiling.op_private = PL_hints;
2792 #ifdef OP_IN_REGISTER
2798 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2800 S_doeval(pTHX_ int gimme, OP** startop)
2808 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2809 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2814 /* set up a scratch pad */
2817 SAVEVPTR(PL_curpad);
2818 SAVESPTR(PL_comppad);
2819 SAVESPTR(PL_comppad_name);
2820 SAVEI32(PL_comppad_name_fill);
2821 SAVEI32(PL_min_intro_pending);
2822 SAVEI32(PL_max_intro_pending);
2825 for (i = cxstack_ix - 1; i >= 0; i--) {
2826 PERL_CONTEXT *cx = &cxstack[i];
2827 if (CxTYPE(cx) == CXt_EVAL)
2829 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2830 caller = cx->blk_sub.cv;
2835 SAVESPTR(PL_compcv);
2836 PL_compcv = (CV*)NEWSV(1104,0);
2837 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2838 CvEVAL_on(PL_compcv);
2840 CvOWNER(PL_compcv) = 0;
2841 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2842 MUTEX_INIT(CvMUTEXP(PL_compcv));
2843 #endif /* USE_THREADS */
2845 PL_comppad = newAV();
2846 av_push(PL_comppad, Nullsv);
2847 PL_curpad = AvARRAY(PL_comppad);
2848 PL_comppad_name = newAV();
2849 PL_comppad_name_fill = 0;
2850 PL_min_intro_pending = 0;
2853 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2854 PL_curpad[0] = (SV*)newAV();
2855 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2856 #endif /* USE_THREADS */
2858 comppadlist = newAV();
2859 AvREAL_off(comppadlist);
2860 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2861 av_store(comppadlist, 1, (SV*)PL_comppad);
2862 CvPADLIST(PL_compcv) = comppadlist;
2865 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2867 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2870 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2872 /* make sure we compile in the right package */
2874 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2875 SAVESPTR(PL_curstash);
2876 PL_curstash = CopSTASH(PL_curcop);
2878 SAVESPTR(PL_beginav);
2879 PL_beginav = newAV();
2880 SAVEFREESV(PL_beginav);
2881 SAVEI32(PL_error_count);
2883 /* try to compile it */
2885 PL_eval_root = Nullop;
2887 PL_curcop = &PL_compiling;
2888 PL_curcop->cop_arybase = 0;
2889 SvREFCNT_dec(PL_rs);
2890 PL_rs = newSVpvn("\n", 1);
2891 if (saveop && saveop->op_flags & OPf_SPECIAL)
2892 PL_in_eval |= EVAL_KEEPERR;
2895 if (yyparse() || PL_error_count || !PL_eval_root) {
2899 I32 optype = 0; /* Might be reset by POPEVAL. */
2904 op_free(PL_eval_root);
2905 PL_eval_root = Nullop;
2907 SP = PL_stack_base + POPMARK; /* pop original mark */
2909 POPBLOCK(cx,PL_curpm);
2915 if (optype == OP_REQUIRE) {
2916 char* msg = SvPVx(ERRSV, n_a);
2917 DIE(aTHX_ "%sCompilation failed in require",
2918 *msg ? msg : "Unknown error\n");
2921 char* msg = SvPVx(ERRSV, n_a);
2923 POPBLOCK(cx,PL_curpm);
2925 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2926 (*msg ? msg : "Unknown error\n"));
2928 SvREFCNT_dec(PL_rs);
2929 PL_rs = SvREFCNT_inc(PL_nrs);
2931 MUTEX_LOCK(&PL_eval_mutex);
2933 COND_SIGNAL(&PL_eval_cond);
2934 MUTEX_UNLOCK(&PL_eval_mutex);
2935 #endif /* USE_THREADS */
2938 SvREFCNT_dec(PL_rs);
2939 PL_rs = SvREFCNT_inc(PL_nrs);
2940 CopLINE_set(&PL_compiling, 0);
2942 *startop = PL_eval_root;
2943 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2944 CvOUTSIDE(PL_compcv) = Nullcv;
2946 SAVEFREEOP(PL_eval_root);
2948 scalarvoid(PL_eval_root);
2949 else if (gimme & G_ARRAY)
2952 scalar(PL_eval_root);
2954 DEBUG_x(dump_eval());
2956 /* Register with debugger: */
2957 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2958 CV *cv = get_cv("DB::postponed", FALSE);
2962 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2964 call_sv((SV*)cv, G_DISCARD);
2968 /* compiled okay, so do it */
2970 CvDEPTH(PL_compcv) = 1;
2971 SP = PL_stack_base + POPMARK; /* pop original mark */
2972 PL_op = saveop; /* The caller may need it. */
2973 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2975 MUTEX_LOCK(&PL_eval_mutex);
2977 COND_SIGNAL(&PL_eval_cond);
2978 MUTEX_UNLOCK(&PL_eval_mutex);
2979 #endif /* USE_THREADS */
2981 RETURNOP(PL_eval_start);
2985 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2987 STRLEN namelen = strlen(name);
2990 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2991 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2992 char *pmc = SvPV_nolen(pmcsv);
2995 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2996 fp = PerlIO_open(name, mode);
2999 if (PerlLIO_stat(name, &pmstat) < 0 ||
3000 pmstat.st_mtime < pmcstat.st_mtime)
3002 fp = PerlIO_open(pmc, mode);
3005 fp = PerlIO_open(name, mode);
3008 SvREFCNT_dec(pmcsv);
3011 fp = PerlIO_open(name, mode);
3019 register PERL_CONTEXT *cx;
3024 SV *namesv = Nullsv;
3026 I32 gimme = GIMME_V;
3027 PerlIO *tryrsfp = 0;
3029 int filter_has_file = 0;
3030 GV *filter_child_proc = 0;
3031 SV *filter_state = 0;
3036 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
3037 UV rev = 0, ver = 0, sver = 0;
3039 U8 *s = (U8*)SvPVX(sv);
3040 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3042 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3045 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3048 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3051 if (PERL_REVISION < rev
3052 || (PERL_REVISION == rev
3053 && (PERL_VERSION < ver
3054 || (PERL_VERSION == ver
3055 && PERL_SUBVERSION < sver))))
3057 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3058 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3059 PERL_VERSION, PERL_SUBVERSION);
3063 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3064 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3065 + ((NV)PERL_SUBVERSION/(NV)1000000)
3066 + 0.00000099 < SvNV(sv))
3070 NV nver = (nrev - rev) * 1000;
3071 UV ver = (UV)(nver + 0.0009);
3072 NV nsver = (nver - ver) * 1000;
3073 UV sver = (UV)(nsver + 0.0009);
3075 /* help out with the "use 5.6" confusion */
3076 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3077 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3078 "this is only v%d.%d.%d, stopped"
3079 " (did you mean v%"UVuf".%"UVuf".0?)",
3080 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3081 PERL_SUBVERSION, rev, ver/100);
3084 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3085 "this is only v%d.%d.%d, stopped",
3086 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3093 name = SvPV(sv, len);
3094 if (!(name && len > 0 && *name))
3095 DIE(aTHX_ "Null filename used");
3096 TAINT_PROPER("require");
3097 if (PL_op->op_type == OP_REQUIRE &&
3098 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3099 *svp != &PL_sv_undef)
3102 /* prepare to compile file */
3104 #ifdef MACOS_TRADITIONAL
3105 if (PERL_FILE_IS_ABSOLUTE(name)
3106 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3109 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3110 /* We consider paths of the form :a:b ambiguous and interpret them first
3111 as global then as local
3113 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3119 if (PERL_FILE_IS_ABSOLUTE(name)
3120 || (*name == '.' && (name[1] == '/' ||
3121 (name[1] == '.' && name[2] == '/'))))
3124 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3128 AV *ar = GvAVn(PL_incgv);
3132 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3135 namesv = NEWSV(806, 0);
3136 for (i = 0; i <= AvFILL(ar); i++) {
3137 SV *dirsv = *av_fetch(ar, i, TRUE);
3143 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3144 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3147 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3148 PTR2UV(SvANY(loader)), name);
3149 tryname = SvPVX(namesv);
3160 if (sv_isobject(loader))
3161 count = call_method("INC", G_ARRAY);
3163 count = call_sv(loader, G_ARRAY);
3173 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3177 if (SvTYPE(arg) == SVt_PVGV) {
3178 IO *io = GvIO((GV *)arg);
3183 tryrsfp = IoIFP(io);
3184 if (IoTYPE(io) == IoTYPE_PIPE) {
3185 /* reading from a child process doesn't
3186 nest -- when returning from reading
3187 the inner module, the outer one is
3188 unreadable (closed?) I've tried to
3189 save the gv to manage the lifespan of
3190 the pipe, but this didn't help. XXX */
3191 filter_child_proc = (GV *)arg;
3192 (void)SvREFCNT_inc(filter_child_proc);
3195 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3196 PerlIO_close(IoOFP(io));
3208 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3210 (void)SvREFCNT_inc(filter_sub);
3213 filter_state = SP[i];
3214 (void)SvREFCNT_inc(filter_state);
3218 tryrsfp = PerlIO_open("/dev/null",
3232 filter_has_file = 0;
3233 if (filter_child_proc) {
3234 SvREFCNT_dec(filter_child_proc);
3235 filter_child_proc = 0;
3238 SvREFCNT_dec(filter_state);
3242 SvREFCNT_dec(filter_sub);
3247 char *dir = SvPVx(dirsv, n_a);
3248 #ifdef MACOS_TRADITIONAL
3250 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3254 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3256 sv_setpv(namesv, unixdir);
3257 sv_catpv(namesv, unixname);
3259 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3262 TAINT_PROPER("require");
3263 tryname = SvPVX(namesv);
3264 #ifdef MACOS_TRADITIONAL
3266 /* Convert slashes in the name part, but not the directory part, to colons */
3268 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3272 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3274 if (tryname[0] == '.' && tryname[1] == '/')
3282 SAVECOPFILE_FREE(&PL_compiling);
3283 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3284 SvREFCNT_dec(namesv);
3286 if (PL_op->op_type == OP_REQUIRE) {
3287 char *msgstr = name;
3288 if (namesv) { /* did we lookup @INC? */
3289 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3290 SV *dirmsgsv = NEWSV(0, 0);
3291 AV *ar = GvAVn(PL_incgv);
3293 sv_catpvn(msg, " in @INC", 8);
3294 if (instr(SvPVX(msg), ".h "))
3295 sv_catpv(msg, " (change .h to .ph maybe?)");
3296 if (instr(SvPVX(msg), ".ph "))
3297 sv_catpv(msg, " (did you run h2ph?)");
3298 sv_catpv(msg, " (@INC contains:");
3299 for (i = 0; i <= AvFILL(ar); i++) {
3300 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3301 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3302 sv_catsv(msg, dirmsgsv);
3304 sv_catpvn(msg, ")", 1);
3305 SvREFCNT_dec(dirmsgsv);
3306 msgstr = SvPV_nolen(msg);
3308 DIE(aTHX_ "Can't locate %s", msgstr);
3314 SETERRNO(0, SS$_NORMAL);
3316 /* Assume success here to prevent recursive requirement. */
3317 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3318 newSVpv(CopFILE(&PL_compiling), 0), 0 );
3322 lex_start(sv_2mortal(newSVpvn("",0)));
3323 SAVEGENERICSV(PL_rsfp_filters);
3324 PL_rsfp_filters = Nullav;
3329 SAVESPTR(PL_compiling.cop_warnings);
3330 if (PL_dowarn & G_WARN_ALL_ON)
3331 PL_compiling.cop_warnings = pWARN_ALL ;
3332 else if (PL_dowarn & G_WARN_ALL_OFF)
3333 PL_compiling.cop_warnings = pWARN_NONE ;
3335 PL_compiling.cop_warnings = pWARN_STD ;
3336 SAVESPTR(PL_compiling.cop_io);
3337 PL_compiling.cop_io = Nullsv;
3339 if (filter_sub || filter_child_proc) {
3340 SV *datasv = filter_add(run_user_filter, Nullsv);
3341 IoLINES(datasv) = filter_has_file;
3342 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3343 IoTOP_GV(datasv) = (GV *)filter_state;
3344 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3347 /* switch to eval mode */
3348 push_return(PL_op->op_next);
3349 PUSHBLOCK(cx, CXt_EVAL, SP);
3350 PUSHEVAL(cx, name, Nullgv);
3352 SAVECOPLINE(&PL_compiling);
3353 CopLINE_set(&PL_compiling, 0);
3357 MUTEX_LOCK(&PL_eval_mutex);
3358 if (PL_eval_owner && PL_eval_owner != thr)
3359 while (PL_eval_owner)
3360 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3361 PL_eval_owner = thr;
3362 MUTEX_UNLOCK(&PL_eval_mutex);
3363 #endif /* USE_THREADS */
3364 return DOCATCH(doeval(gimme, NULL));
3369 return pp_require();
3375 register PERL_CONTEXT *cx;
3377 I32 gimme = GIMME_V, was = PL_sub_generation;
3378 char tbuf[TYPE_DIGITS(long) + 12];
3379 char *tmpbuf = tbuf;
3384 if (!SvPV(sv,len) || !len)
3386 TAINT_PROPER("eval");
3392 /* switch to eval mode */
3394 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3395 SV *sv = sv_newmortal();
3396 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3397 (unsigned long)++PL_evalseq,
3398 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3402 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3403 SAVECOPFILE_FREE(&PL_compiling);
3404 CopFILE_set(&PL_compiling, tmpbuf+2);
3405 SAVECOPLINE(&PL_compiling);
3406 CopLINE_set(&PL_compiling, 1);
3407 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3408 deleting the eval's FILEGV from the stash before gv_check() runs
3409 (i.e. before run-time proper). To work around the coredump that
3410 ensues, we always turn GvMULTI_on for any globals that were
3411 introduced within evals. See force_ident(). GSAR 96-10-12 */
3412 safestr = savepv(tmpbuf);
3413 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3415 PL_hints = PL_op->op_targ;
3416 SAVESPTR(PL_compiling.cop_warnings);
3417 if (specialWARN(PL_curcop->cop_warnings))
3418 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3420 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3421 SAVEFREESV(PL_compiling.cop_warnings);
3423 SAVESPTR(PL_compiling.cop_io);
3424 if (specialCopIO(PL_curcop->cop_io))
3425 PL_compiling.cop_io = PL_curcop->cop_io;
3427 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3428 SAVEFREESV(PL_compiling.cop_io);
3431 push_return(PL_op->op_next);
3432 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3433 PUSHEVAL(cx, 0, Nullgv);
3435 /* prepare to compile string */
3437 if (PERLDB_LINE && PL_curstash != PL_debstash)
3438 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3441 MUTEX_LOCK(&PL_eval_mutex);
3442 if (PL_eval_owner && PL_eval_owner != thr)
3443 while (PL_eval_owner)
3444 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3445 PL_eval_owner = thr;
3446 MUTEX_UNLOCK(&PL_eval_mutex);
3447 #endif /* USE_THREADS */
3448 ret = doeval(gimme, NULL);
3449 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3450 && ret != PL_op->op_next) { /* Successive compilation. */
3451 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3453 return DOCATCH(ret);
3463 register PERL_CONTEXT *cx;
3465 U8 save_flags = PL_op -> op_flags;
3470 retop = pop_return();
3473 if (gimme == G_VOID)
3475 else if (gimme == G_SCALAR) {
3478 if (SvFLAGS(TOPs) & SVs_TEMP)
3481 *MARK = sv_mortalcopy(TOPs);
3485 *MARK = &PL_sv_undef;
3490 /* in case LEAVE wipes old return values */
3491 for (mark = newsp + 1; mark <= SP; mark++) {
3492 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3493 *mark = sv_mortalcopy(*mark);
3494 TAINT_NOT; /* Each item is independent */
3498 PL_curpm = newpm; /* Don't pop $1 et al till now */
3501 assert(CvDEPTH(PL_compcv) == 1);
3503 CvDEPTH(PL_compcv) = 0;
3506 if (optype == OP_REQUIRE &&
3507 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3509 /* Unassume the success we assumed earlier. */
3510 SV *nsv = cx->blk_eval.old_namesv;
3511 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3512 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3513 /* die_where() did LEAVE, or we won't be here */
3517 if (!(save_flags & OPf_SPECIAL))
3527 register PERL_CONTEXT *cx;
3528 I32 gimme = GIMME_V;
3533 push_return(cLOGOP->op_other->op_next);
3534 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3537 PL_in_eval = EVAL_INEVAL;
3540 return DOCATCH(PL_op->op_next);
3550 register PERL_CONTEXT *cx;
3558 if (gimme == G_VOID)
3560 else if (gimme == G_SCALAR) {
3563 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3566 *MARK = sv_mortalcopy(TOPs);
3570 *MARK = &PL_sv_undef;
3575 /* in case LEAVE wipes old return values */
3576 for (mark = newsp + 1; mark <= SP; mark++) {
3577 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3578 *mark = sv_mortalcopy(*mark);
3579 TAINT_NOT; /* Each item is independent */
3583 PL_curpm = newpm; /* Don't pop $1 et al till now */
3591 S_doparseform(pTHX_ SV *sv)
3594 register char *s = SvPV_force(sv, len);
3595 register char *send = s + len;
3596 register char *base;
3597 register I32 skipspaces = 0;
3600 bool postspace = FALSE;
3608 Perl_croak(aTHX_ "Null picture in formline");
3610 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3615 *fpc++ = FF_LINEMARK;
3616 noblank = repeat = FALSE;
3634 case ' ': case '\t':
3645 *fpc++ = FF_LITERAL;
3653 *fpc++ = skipspaces;
3657 *fpc++ = FF_NEWLINE;
3661 arg = fpc - linepc + 1;
3668 *fpc++ = FF_LINEMARK;
3669 noblank = repeat = FALSE;
3678 ischop = s[-1] == '^';
3684 arg = (s - base) - 1;
3686 *fpc++ = FF_LITERAL;
3695 *fpc++ = FF_LINEGLOB;
3697 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3698 arg = ischop ? 512 : 0;
3708 arg |= 256 + (s - f);
3710 *fpc++ = s - base; /* fieldsize for FETCH */
3711 *fpc++ = FF_DECIMAL;
3714 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3715 arg = ischop ? 512 : 0;
3717 s++; /* skip the '0' first */
3726 arg |= 256 + (s - f);
3728 *fpc++ = s - base; /* fieldsize for FETCH */
3729 *fpc++ = FF_0DECIMAL;
3734 bool ismore = FALSE;
3737 while (*++s == '>') ;
3738 prespace = FF_SPACE;
3740 else if (*s == '|') {
3741 while (*++s == '|') ;
3742 prespace = FF_HALFSPACE;
3747 while (*++s == '<') ;
3750 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3754 *fpc++ = s - base; /* fieldsize for FETCH */
3756 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3774 { /* need to jump to the next word */
3776 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3777 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3778 s = SvPVX(sv) + SvCUR(sv) + z;
3780 Copy(fops, s, arg, U16);
3782 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3787 * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3789 * The original code was written in conjunction with BSD Computer Software
3790 * Research Group at University of California, Berkeley.
3792 * See also: "Optimistic Merge Sort" (SODA '92)
3794 * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3796 * The code can be distributed under the same terms as Perl itself.
3801 #include <sys/types.h>
3806 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3807 #define Safefree(VAR) free(VAR)
3808 typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3809 #endif /* TESTHARNESS */
3811 typedef char * aptr; /* pointer for arithmetic on sizes */
3812 typedef SV * gptr; /* pointers in our lists */
3814 /* Binary merge internal sort, with a few special mods
3815 ** for the special perl environment it now finds itself in.
3817 ** Things that were once options have been hotwired
3818 ** to values suitable for this use. In particular, we'll always
3819 ** initialize looking for natural runs, we'll always produce stable
3820 ** output, and we'll always do Peter McIlroy's binary merge.
3823 /* Pointer types for arithmetic and storage and convenience casts */
3825 #define APTR(P) ((aptr)(P))
3826 #define GPTP(P) ((gptr *)(P))
3827 #define GPPP(P) ((gptr **)(P))
3830 /* byte offset from pointer P to (larger) pointer Q */
3831 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3833 #define PSIZE sizeof(gptr)
3835 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3838 #define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
3839 #define PNBYTE(N) ((N) << (PSHIFT))
3840 #define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
3842 /* Leave optimization to compiler */
3843 #define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
3844 #define PNBYTE(N) ((N) * (PSIZE))
3845 #define PINDEX(P, N) (GPTP(P) + (N))
3848 /* Pointer into other corresponding to pointer into this */
3849 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3851 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3854 /* Runs are identified by a pointer in the auxilliary list.
3855 ** The pointer is at the start of the list,
3856 ** and it points to the start of the next list.
3857 ** NEXT is used as an lvalue, too.
3860 #define NEXT(P) (*GPPP(P))
3863 /* PTHRESH is the minimum number of pairs with the same sense to justify
3864 ** checking for a run and extending it. Note that PTHRESH counts PAIRS,
3865 ** not just elements, so PTHRESH == 8 means a run of 16.
3870 /* RTHRESH is the number of elements in a run that must compare low
3871 ** to the low element from the opposing run before we justify
3872 ** doing a binary rampup instead of single stepping.
3873 ** In random input, N in a row low should only happen with
3874 ** probability 2^(1-N), so we can risk that we are dealing
3875 ** with orderly input without paying much when we aren't.
3882 ** Overview of algorithm and variables.
3883 ** The array of elements at list1 will be organized into runs of length 2,
3884 ** or runs of length >= 2 * PTHRESH. We only try to form long runs when
3885 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3887 ** Unless otherwise specified, pair pointers address the first of two elements.
3889 ** b and b+1 are a pair that compare with sense ``sense''.
3890 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3892 ** p2 parallels b in the list2 array, where runs are defined by
3895 ** t represents the ``top'' of the adjacent pairs that might extend
3896 ** the run beginning at b. Usually, t addresses a pair
3897 ** that compares with opposite sense from (b,b+1).
3898 ** However, it may also address a singleton element at the end of list1,
3899 ** or it may be equal to ``last'', the first element beyond list1.
3901 ** r addresses the Nth pair following b. If this would be beyond t,
3902 ** we back it off to t. Only when r is less than t do we consider the
3903 ** run long enough to consider checking.
3905 ** q addresses a pair such that the pairs at b through q already form a run.
3906 ** Often, q will equal b, indicating we only are sure of the pair itself.
3907 ** However, a search on the previous cycle may have revealed a longer run,
3908 ** so q may be greater than b.
3910 ** p is used to work back from a candidate r, trying to reach q,
3911 ** which would mean b through r would be a run. If we discover such a run,
3912 ** we start q at r and try to push it further towards t.
3913 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3914 ** In any event, after the check (if any), we have two main cases.
3916 ** 1) Short run. b <= q < p <= r <= t.
3917 ** b through q is a run (perhaps trivial)
3918 ** q through p are uninteresting pairs
3919 ** p through r is a run
3921 ** 2) Long run. b < r <= q < t.
3922 ** b through q is a run (of length >= 2 * PTHRESH)
3924 ** Note that degenerate cases are not only possible, but likely.
3925 ** For example, if the pair following b compares with opposite sense,
3926 ** then b == q < p == r == t.
3931 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3934 register gptr *b, *p, *q, *t, *p2;
3935 register gptr c, *last, *r;
3939 last = PINDEX(b, nmemb);
3940 sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3941 for (p2 = list2; b < last; ) {
3942 /* We just started, or just reversed sense.
3943 ** Set t at end of pairs with the prevailing sense.
3945 for (p = b+2, t = p; ++p < last; t = ++p) {
3946 if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3949 /* Having laid out the playing field, look for long runs */
3951 p = r = b + (2 * PTHRESH);
3952 if (r >= t) p = r = t; /* too short to care about */
3954 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3957 /* b through r is a (long) run.
3958 ** Extend it as far as possible.
3961 while (((p += 2) < t) &&
3962 ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3963 r = p = q + 2; /* no simple pairs, no after-run */
3966 if (q > b) { /* run of greater than 2 at b */
3969 /* pick up singleton, if possible */
3971 ((t + 1) == last) &&
3972 ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3973 savep = r = p = q = last;
3974 p2 = NEXT(p2) = p2 + (p - b);
3975 if (sense) while (b < --p) {
3982 while (q < p) { /* simple pairs */
3983 p2 = NEXT(p2) = p2 + 2;
3990 if (((b = p) == t) && ((t+1) == last)) {
4002 /* Overview of bmerge variables:
4004 ** list1 and list2 address the main and auxiliary arrays.
4005 ** They swap identities after each merge pass.
4006 ** Base points to the original list1, so we can tell if
4007 ** the pointers ended up where they belonged (or must be copied).
4009 ** When we are merging two lists, f1 and f2 are the next elements
4010 ** on the respective lists. l1 and l2 mark the end of the lists.
4011 ** tp2 is the current location in the merged list.
4013 ** p1 records where f1 started.
4014 ** After the merge, a new descriptor is built there.
4016 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4017 ** It is used to identify and delimit the runs.
4019 ** In the heat of determining where q, the greater of the f1/f2 elements,
4020 ** belongs in the other list, b, t and p, represent bottom, top and probe
4021 ** locations, respectively, in the other list.
4022 ** They make convenient temporary pointers in other places.
4026 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4030 register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4031 gptr *aux, *list2, *p2, *last;
4035 if (nmemb <= 1) return; /* sorted trivially */
4036 New(799,list2,nmemb,gptr); /* allocate auxilliary array */
4038 dynprep(aTHX_ list1, list2, nmemb, cmp);
4039 last = PINDEX(list2, nmemb);
4040 while (NEXT(list2) != last) {
4041 /* More than one run remains. Do some merging to reduce runs. */
4043 for (tp2 = p2 = list2; p2 != last;) {
4044 /* The new first run begins where the old second list ended.
4045 ** Use the p2 ``parallel'' pointer to identify the end of the run.
4049 f2 = l1 = POTHER(t, list2, list1);
4050 if (t != last) t = NEXT(t);
4051 l2 = POTHER(t, list2, list1);
4053 while (f1 < l1 && f2 < l2) {
4054 /* If head 1 is larger than head 2, find ALL the elements
4055 ** in list 2 strictly less than head1, write them all,
4056 ** then head 1. Then compare the new heads, and repeat,
4057 ** until one or both lists are exhausted.
4059 ** In all comparisons (after establishing
4060 ** which head to merge) the item to merge
4061 ** (at pointer q) is the first operand of
4062 ** the comparison. When we want to know
4063 ** if ``q is strictly less than the other'',
4065 ** cmp(q, other) < 0
4066 ** because stability demands that we treat equality
4067 ** as high when q comes from l2, and as low when
4068 ** q was from l1. So we ask the question by doing
4069 ** cmp(q, other) <= sense
4070 ** and make sense == 0 when equality should look low,
4071 ** and -1 when equality should look high.
4075 if (cmp(aTHX_ *f1, *f2) <= 0) {
4076 q = f2; b = f1; t = l1;
4079 q = f1; b = f2; t = l2;
4086 ** Leave t at something strictly
4087 ** greater than q (or at the end of the list),
4088 ** and b at something strictly less than q.
4090 for (i = 1, run = 0 ;;) {
4091 if ((p = PINDEX(b, i)) >= t) {
4093 if (((p = PINDEX(t, -1)) > b) &&
4094 (cmp(aTHX_ *q, *p) <= sense))
4098 } else if (cmp(aTHX_ *q, *p) <= sense) {
4102 if (++run >= RTHRESH) i += i;
4106 /* q is known to follow b and must be inserted before t.
4107 ** Increment b, so the range of possibilities is [b,t).
4108 ** Round binary split down, to favor early appearance.
4109 ** Adjust b and t until q belongs just before t.
4114 p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4115 if (cmp(aTHX_ *q, *p) <= sense) {
4121 /* Copy all the strictly low elements */
4124 FROMTOUPTO(f2, tp2, t);
4127 FROMTOUPTO(f1, tp2, t);
4133 /* Run out remaining list */
4135 if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4136 } else FROMTOUPTO(f1, tp2, l1);
4137 p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4142 last = PINDEX(list2, nmemb);
4144 if (base == list2) {
4145 last = PINDEX(list1, nmemb);
4146 FROMTOUPTO(list1, list2, last);
4161 sortcv(pTHXo_ SV *a, SV *b)
4163 I32 oldsaveix = PL_savestack_ix;
4164 I32 oldscopeix = PL_scopestack_ix;
4166 GvSV(PL_firstgv) = a;
4167 GvSV(PL_secondgv) = b;
4168 PL_stack_sp = PL_stack_base;
4171 if (PL_stack_sp != PL_stack_base + 1)
4172 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4173 if (!SvNIOKp(*PL_stack_sp))
4174 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4175 result = SvIV(*PL_stack_sp);
4176 while (PL_scopestack_ix > oldscopeix) {
4179 leave_scope(oldsaveix);
4184 sortcv_stacked(pTHXo_ SV *a, SV *b)
4186 I32 oldsaveix = PL_savestack_ix;
4187 I32 oldscopeix = PL_scopestack_ix;
4192 av = (AV*)PL_curpad[0];
4194 av = GvAV(PL_defgv);
4197 if (AvMAX(av) < 1) {
4198 SV** ary = AvALLOC(av);
4199 if (AvARRAY(av) != ary) {
4200 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4201 SvPVX(av) = (char*)ary;
4203 if (AvMAX(av) < 1) {
4206 SvPVX(av) = (char*)ary;
4213 PL_stack_sp = PL_stack_base;
4216 if (PL_stack_sp != PL_stack_base + 1)
4217 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4218 if (!SvNIOKp(*PL_stack_sp))
4219 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4220 result = SvIV(*PL_stack_sp);
4221 while (PL_scopestack_ix > oldscopeix) {
4224 leave_scope(oldsaveix);
4229 sortcv_xsub(pTHXo_ SV *a, SV *b)
4232 I32 oldsaveix = PL_savestack_ix;
4233 I32 oldscopeix = PL_scopestack_ix;
4235 CV *cv=(CV*)PL_sortcop;
4243 (void)(*CvXSUB(cv))(aTHXo_ cv);
4244 if (PL_stack_sp != PL_stack_base + 1)
4245 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4246 if (!SvNIOKp(*PL_stack_sp))
4247 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4248 result = SvIV(*PL_stack_sp);
4249 while (PL_scopestack_ix > oldscopeix) {
4252 leave_scope(oldsaveix);
4258 sv_ncmp(pTHXo_ SV *a, SV *b)
4262 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4266 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4270 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4272 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4274 if (PL_amagic_generation) { \
4275 if (SvAMAGIC(left)||SvAMAGIC(right))\
4276 *svp = amagic_call(left, \
4284 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4287 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4292 I32 i = SvIVX(tmpsv);
4302 return sv_ncmp(aTHXo_ a, b);
4306 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4309 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4314 I32 i = SvIVX(tmpsv);
4324 return sv_i_ncmp(aTHXo_ a, b);
4328 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4331 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4336 I32 i = SvIVX(tmpsv);
4346 return sv_cmp(str1, str2);
4350 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4353 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4358 I32 i = SvIVX(tmpsv);
4368 return sv_cmp_locale(str1, str2);
4372 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4374 SV *datasv = FILTER_DATA(idx);
4375 int filter_has_file = IoLINES(datasv);
4376 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4377 SV *filter_state = (SV *)IoTOP_GV(datasv);
4378 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4381 /* I was having segfault trouble under Linux 2.2.5 after a
4382 parse error occured. (Had to hack around it with a test
4383 for PL_error_count == 0.) Solaris doesn't segfault --
4384 not sure where the trouble is yet. XXX */
4386 if (filter_has_file) {
4387 len = FILTER_READ(idx+1, buf_sv, maxlen);
4390 if (filter_sub && len >= 0) {
4401 PUSHs(sv_2mortal(newSViv(maxlen)));
4403 PUSHs(filter_state);
4406 count = call_sv(filter_sub, G_SCALAR);
4422 IoLINES(datasv) = 0;
4423 if (filter_child_proc) {
4424 SvREFCNT_dec(filter_child_proc);
4425 IoFMT_GV(datasv) = Nullgv;
4428 SvREFCNT_dec(filter_state);
4429 IoTOP_GV(datasv) = Nullgv;
4432 SvREFCNT_dec(filter_sub);
4433 IoBOTTOM_GV(datasv) = Nullgv;
4435 filter_del(run_user_filter);
4444 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4446 return sv_cmp_locale(str1, str2);
4450 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4452 return sv_cmp(str1, str2);
4455 #endif /* PERL_OBJECT */