summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/pp_ctl.c
diff options
context:
space:
mode:
authormarkm <markm@FreeBSD.org>2002-05-16 10:09:28 +0000
committermarkm <markm@FreeBSD.org>2002-05-16 10:09:28 +0000
commitf56e05005c751822074f0a22aa9a98d2eb189924 (patch)
treee28fc632241c9d248069d45dd9ab2a41fa64868f /contrib/perl5/pp_ctl.c
parent344ddc14973a1519f100f54051dcb068069fe43c (diff)
downloadFreeBSD-src-f56e05005c751822074f0a22aa9a98d2eb189924.zip
FreeBSD-src-f56e05005c751822074f0a22aa9a98d2eb189924.tar.gz
Perl is no longer in base. Long live the port!
Diffstat (limited to 'contrib/perl5/pp_ctl.c')
-rw-r--r--contrib/perl5/pp_ctl.c4665
1 files changed, 0 insertions, 4665 deletions
diff --git a/contrib/perl5/pp_ctl.c b/contrib/perl5/pp_ctl.c
deleted file mode 100644
index b267060..0000000
--- a/contrib/perl5/pp_ctl.c
+++ /dev/null
@@ -1,4665 +0,0 @@
-/* pp_ctl.c
- *
- * Copyright (c) 1991-2001, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- */
-
-/*
- * Now far ahead the Road has gone,
- * And I must follow, if I can,
- * Pursuing it with eager feet,
- * Until it joins some larger way
- * Where many paths and errands meet.
- * And whither then? I cannot say.
- */
-
-#include "EXTERN.h"
-#define PERL_IN_PP_CTL_C
-#include "perl.h"
-
-#ifndef WORD_ALIGN
-#define WORD_ALIGN sizeof(U16)
-#endif
-
-#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
-
-static I32 sortcv(pTHXo_ SV *a, SV *b);
-static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
-static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
-static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
-static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
-static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
-
-#ifdef PERL_OBJECT
-static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
-static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
-#else
-#define sv_cmp_static Perl_sv_cmp
-#define sv_cmp_locale_static Perl_sv_cmp_locale
-#endif
-
-PP(pp_wantarray)
-{
- dSP;
- I32 cxix;
- EXTEND(SP, 1);
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- RETPUSHUNDEF;
-
- switch (cxstack[cxix].blk_gimme) {
- case G_ARRAY:
- RETPUSHYES;
- case G_SCALAR:
- RETPUSHNO;
- default:
- RETPUSHUNDEF;
- }
-}
-
-PP(pp_regcmaybe)
-{
- return NORMAL;
-}
-
-PP(pp_regcreset)
-{
- /* XXXX Should store the old value to allow for tie/overload - and
- restore in regcomp, where marked with XXXX. */
- PL_reginterp_cnt = 0;
- return NORMAL;
-}
-
-PP(pp_regcomp)
-{
- dSP;
- register PMOP *pm = (PMOP*)cLOGOP->op_other;
- register char *t;
- SV *tmpstr;
- STRLEN len;
- MAGIC *mg = Null(MAGIC*);
-
- tmpstr = POPs;
- if (SvROK(tmpstr)) {
- SV *sv = SvRV(tmpstr);
- if(SvMAGICAL(sv))
- mg = mg_find(sv, 'r');
- }
- if (mg) {
- regexp *re = (regexp *)mg->mg_obj;
- ReREFCNT_dec(pm->op_pmregexp);
- pm->op_pmregexp = ReREFCNT_inc(re);
- }
- else {
- t = SvPV(tmpstr, len);
-
- /* Check against the last compiled regexp. */
- if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
- pm->op_pmregexp->prelen != len ||
- memNE(pm->op_pmregexp->precomp, t, len))
- {
- if (pm->op_pmregexp) {
- ReREFCNT_dec(pm->op_pmregexp);
- pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
- }
- if (PL_op->op_flags & OPf_SPECIAL)
- PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
-
- pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
- if (DO_UTF8(tmpstr))
- pm->op_pmdynflags |= PMdf_UTF8;
- pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
- inside tie/overload accessors. */
- }
- }
-
-#ifndef INCOMPLETE_TAINTS
- if (PL_tainting) {
- if (PL_tainted)
- pm->op_pmdynflags |= PMdf_TAINTED;
- else
- pm->op_pmdynflags &= ~PMdf_TAINTED;
- }
-#endif
-
- if (!pm->op_pmregexp->prelen && PL_curpm)
- pm = PL_curpm;
- else if (strEQ("\\s+", pm->op_pmregexp->precomp))
- pm->op_pmflags |= PMf_WHITE;
-
- /* XXX runtime compiled output needs to move to the pad */
- if (pm->op_pmflags & PMf_KEEP) {
- pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
-#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
- /* XXX can't change the optree at runtime either */
- cLOGOP->op_first->op_next = PL_op->op_next;
-#endif
- }
- RETURN;
-}
-
-PP(pp_substcont)
-{
- dSP;
- register PMOP *pm = (PMOP*) cLOGOP->op_other;
- register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- register SV *dstr = cx->sb_dstr;
- register char *s = cx->sb_s;
- register char *m = cx->sb_m;
- char *orig = cx->sb_orig;
- register REGEXP *rx = cx->sb_rx;
-
- rxres_restore(&cx->sb_rxres, rx);
-
- if (cx->sb_iters++) {
- if (cx->sb_iters > cx->sb_maxiters)
- DIE(aTHX_ "Substitution loop");
-
- if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
- cx->sb_rxtainted |= 2;
- sv_catsv(dstr, POPs);
-
- /* Are we done */
- if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
- s == m, cx->sb_targ, NULL,
- ((cx->sb_rflags & REXEC_COPY_STR)
- ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
- : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
- {
- SV *targ = cx->sb_targ;
- bool isutf8;
-
- sv_catpvn(dstr, s, cx->sb_strend - s);
- cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
-
- (void)SvOOK_off(targ);
- Safefree(SvPVX(targ));
- SvPVX(targ) = SvPVX(dstr);
- SvCUR_set(targ, SvCUR(dstr));
- SvLEN_set(targ, SvLEN(dstr));
- isutf8 = DO_UTF8(dstr);
- SvPVX(dstr) = 0;
- sv_free(dstr);
-
- TAINT_IF(cx->sb_rxtainted & 1);
- PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
-
- (void)SvPOK_only(targ);
- if (isutf8)
- SvUTF8_on(targ);
- TAINT_IF(cx->sb_rxtainted);
- SvSETMAGIC(targ);
- SvTAINT(targ);
-
- LEAVE_SCOPE(cx->sb_oldsave);
- POPSUBST(cx);
- RETURNOP(pm->op_next);
- }
- }
- if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
- m = s;
- s = orig;
- cx->sb_orig = orig = rx->subbeg;
- s = orig + (m - s);
- cx->sb_strend = s + (cx->sb_strend - m);
- }
- cx->sb_m = m = rx->startp[0] + orig;
- sv_catpvn(dstr, s, m-s);
- cx->sb_s = rx->endp[0] + orig;
- { /* Update the pos() information. */
- SV *sv = cx->sb_targ;
- MAGIC *mg;
- I32 i;
- if (SvTYPE(sv) < SVt_PVMG)
- SvUPGRADE(sv, SVt_PVMG);
- if (!(mg = mg_find(sv, 'g'))) {
- sv_magic(sv, Nullsv, 'g', Nullch, 0);
- mg = mg_find(sv, 'g');
- }
- i = m - orig;
- if (DO_UTF8(sv))
- sv_pos_b2u(sv, &i);
- mg->mg_len = i;
- }
- cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
- rxres_save(&cx->sb_rxres, rx);
- RETURNOP(pm->op_pmreplstart);
-}
-
-void
-Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
-{
- UV *p = (UV*)*rsp;
- U32 i;
-
- if (!p || p[1] < rx->nparens) {
- i = 6 + rx->nparens * 2;
- if (!p)
- New(501, p, i, UV);
- else
- Renew(p, i, UV);
- *rsp = (void*)p;
- }
-
- *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
- RX_MATCH_COPIED_off(rx);
-
- *p++ = rx->nparens;
-
- *p++ = PTR2UV(rx->subbeg);
- *p++ = (UV)rx->sublen;
- for (i = 0; i <= rx->nparens; ++i) {
- *p++ = (UV)rx->startp[i];
- *p++ = (UV)rx->endp[i];
- }
-}
-
-void
-Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
-{
- UV *p = (UV*)*rsp;
- U32 i;
-
- if (RX_MATCH_COPIED(rx))
- Safefree(rx->subbeg);
- RX_MATCH_COPIED_set(rx, *p);
- *p++ = 0;
-
- rx->nparens = *p++;
-
- rx->subbeg = INT2PTR(char*,*p++);
- rx->sublen = (I32)(*p++);
- for (i = 0; i <= rx->nparens; ++i) {
- rx->startp[i] = (I32)(*p++);
- rx->endp[i] = (I32)(*p++);
- }
-}
-
-void
-Perl_rxres_free(pTHX_ void **rsp)
-{
- UV *p = (UV*)*rsp;
-
- if (p) {
- Safefree(INT2PTR(char*,*p));
- Safefree(p);
- *rsp = Null(void*);
- }
-}
-
-PP(pp_formline)
-{
- dSP; dMARK; dORIGMARK;
- register SV *tmpForm = *++MARK;
- register U16 *fpc;
- register char *t;
- register char *f;
- register char *s;
- register char *send;
- register I32 arg;
- register SV *sv;
- char *item;
- I32 itemsize;
- I32 fieldsize;
- I32 lines = 0;
- bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
- char *chophere;
- char *linemark;
- NV value;
- bool gotsome;
- STRLEN len;
- STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
- bool item_is_utf = FALSE;
-
- if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
- if (SvREADONLY(tmpForm)) {
- SvREADONLY_off(tmpForm);
- doparseform(tmpForm);
- SvREADONLY_on(tmpForm);
- }
- else
- doparseform(tmpForm);
- }
-
- SvPV_force(PL_formtarget, len);
- t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
- t += len;
- f = SvPV(tmpForm, len);
- /* need to jump to the next word */
- s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
-
- fpc = (U16*)s;
-
- for (;;) {
- DEBUG_f( {
- char *name = "???";
- arg = -1;
- switch (*fpc) {
- case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
- case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
- case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
- case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
- case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
-
- case FF_CHECKNL: name = "CHECKNL"; break;
- case FF_CHECKCHOP: name = "CHECKCHOP"; break;
- case FF_SPACE: name = "SPACE"; break;
- case FF_HALFSPACE: name = "HALFSPACE"; break;
- case FF_ITEM: name = "ITEM"; break;
- case FF_CHOP: name = "CHOP"; break;
- case FF_LINEGLOB: name = "LINEGLOB"; break;
- case FF_NEWLINE: name = "NEWLINE"; break;
- case FF_MORE: name = "MORE"; break;
- case FF_LINEMARK: name = "LINEMARK"; break;
- case FF_END: name = "END"; break;
- }
- if (arg >= 0)
- PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
- else
- PerlIO_printf(Perl_debug_log, "%-16s\n", name);
- } )
- switch (*fpc++) {
- case FF_LINEMARK:
- linemark = t;
- lines++;
- gotsome = FALSE;
- break;
-
- case FF_LITERAL:
- arg = *fpc++;
- while (arg--)
- *t++ = *f++;
- break;
-
- case FF_SKIP:
- f += *fpc++;
- break;
-
- case FF_FETCH:
- arg = *fpc++;
- f += arg;
- fieldsize = arg;
-
- if (MARK < SP)
- sv = *++MARK;
- else {
- sv = &PL_sv_no;
- if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
- }
- break;
-
- case FF_CHECKNL:
- item = s = SvPV(sv, len);
- itemsize = len;
- if (DO_UTF8(sv)) {
- itemsize = sv_len_utf8(sv);
- if (itemsize != len) {
- I32 itembytes;
- if (itemsize > fieldsize) {
- itemsize = fieldsize;
- itembytes = itemsize;
- sv_pos_u2b(sv, &itembytes, 0);
- }
- else
- itembytes = len;
- send = chophere = s + itembytes;
- while (s < send) {
- if (*s & ~31)
- gotsome = TRUE;
- else if (*s == '\n')
- break;
- s++;
- }
- item_is_utf = TRUE;
- itemsize = s - item;
- sv_pos_b2u(sv, &itemsize);
- break;
- }
- }
- item_is_utf = FALSE;
- if (itemsize > fieldsize)
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s & ~31)
- gotsome = TRUE;
- else if (*s == '\n')
- break;
- s++;
- }
- itemsize = s - item;
- break;
-
- case FF_CHECKCHOP:
- item = s = SvPV(sv, len);
- itemsize = len;
- if (DO_UTF8(sv)) {
- itemsize = sv_len_utf8(sv);
- if (itemsize != len) {
- I32 itembytes;
- if (itemsize <= fieldsize) {
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - item;
- break;
- }
- if (*s++ & ~31)
- gotsome = TRUE;
- }
- }
- else {
- itemsize = fieldsize;
- itembytes = itemsize;
- sv_pos_u2b(sv, &itembytes, 0);
- send = chophere = s + itembytes;
- while (s < send || (s == send && isSPACE(*s))) {
- if (isSPACE(*s)) {
- if (chopspace)
- chophere = s;
- if (*s == '\r')
- break;
- }
- else {
- if (*s & ~31)
- gotsome = TRUE;
- if (strchr(PL_chopset, *s))
- chophere = s + 1;
- }
- s++;
- }
- itemsize = chophere - item;
- sv_pos_b2u(sv, &itemsize);
- }
- item_is_utf = TRUE;
- break;
- }
- }
- item_is_utf = FALSE;
- if (itemsize <= fieldsize) {
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - item;
- break;
- }
- if (*s++ & ~31)
- gotsome = TRUE;
- }
- }
- else {
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send || (s == send && isSPACE(*s))) {
- if (isSPACE(*s)) {
- if (chopspace)
- chophere = s;
- if (*s == '\r')
- break;
- }
- else {
- if (*s & ~31)
- gotsome = TRUE;
- if (strchr(PL_chopset, *s))
- chophere = s + 1;
- }
- s++;
- }
- itemsize = chophere - item;
- }
- break;
-
- case FF_SPACE:
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- break;
-
- case FF_HALFSPACE:
- arg = fieldsize - itemsize;
- if (arg) {
- arg /= 2;
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- break;
-
- case FF_ITEM:
- arg = itemsize;
- s = item;
- if (item_is_utf) {
- while (arg--) {
- if (UTF8_IS_CONTINUED(*s)) {
- switch (UTF8SKIP(s)) {
- case 7: *t++ = *s++;
- case 6: *t++ = *s++;
- case 5: *t++ = *s++;
- case 4: *t++ = *s++;
- case 3: *t++ = *s++;
- case 2: *t++ = *s++;
- case 1: *t++ = *s++;
- }
- }
- else {
- if ( !((*t++ = *s++) & ~31) )
- t[-1] = ' ';
- }
- }
- break;
- }
- while (arg--) {
-#ifdef EBCDIC
- int ch = *t++ = *s++;
- if (iscntrl(ch))
-#else
- if ( !((*t++ = *s++) & ~31) )
-#endif
- t[-1] = ' ';
- }
- break;
-
- case FF_CHOP:
- s = chophere;
- if (chopspace) {
- while (*s && isSPACE(*s))
- s++;
- }
- sv_chop(sv,s);
- break;
-
- case FF_LINEGLOB:
- item = s = SvPV(sv, len);
- itemsize = len;
- item_is_utf = FALSE; /* XXX is this correct? */
- if (itemsize) {
- gotsome = TRUE;
- send = s + itemsize;
- while (s < send) {
- if (*s++ == '\n') {
- if (s == send)
- itemsize--;
- else
- lines++;
- }
- }
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- sv_catpvn(PL_formtarget, item, itemsize);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
- t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
- }
- break;
-
- case FF_DECIMAL:
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
- arg = *fpc++;
- if ((arg & 512) && !SvOK(sv)) {
- arg = fieldsize;
- while (arg--)
- *t++ = ' ';
- break;
- }
- gotsome = TRUE;
- value = SvNV(sv);
- /* Formats aren't yet marked for locales, so assume "yes". */
- {
- STORE_NUMERIC_STANDARD_SET_LOCAL();
-#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
-#else
- if (arg & 256) {
- sprintf(t, "%#*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0f",
- (int) fieldsize, value);
- }
-#endif
- RESTORE_NUMERIC_STANDARD();
- }
- t += fieldsize;
- break;
-
- case FF_NEWLINE:
- f++;
- while (t-- > linemark && *t == ' ') ;
- t++;
- *t++ = '\n';
- break;
-
- case FF_BLANK:
- arg = *fpc++;
- if (gotsome) {
- if (arg) { /* repeat until fields exhausted? */
- *t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- lines += FmLINES(PL_formtarget);
- if (lines == 200) {
- arg = t - linemark;
- if (strnEQ(linemark, linemark - arg, arg))
- DIE(aTHX_ "Runaway format");
- }
- FmLINES(PL_formtarget) = lines;
- SP = ORIGMARK;
- RETURNOP(cLISTOP->op_first);
- }
- }
- else {
- t = linemark;
- lines--;
- }
- break;
-
- case FF_MORE:
- s = chophere;
- send = item + len;
- if (chopspace) {
- while (*s && isSPACE(*s) && s < send)
- s++;
- }
- if (s < send) {
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- s = t - 3;
- if (strnEQ(s," ",3)) {
- while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
- s--;
- }
- *s++ = '.';
- *s++ = '.';
- *s++ = '.';
- }
- break;
-
- case FF_END:
- *t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- FmLINES(PL_formtarget) += lines;
- SP = ORIGMARK;
- RETPUSHYES;
- }
- }
-}
-
-PP(pp_grepstart)
-{
- dSP;
- SV *src;
-
- if (PL_stack_base + *PL_markstack_ptr == SP) {
- (void)POPMARK;
- if (GIMME_V == G_SCALAR)
- XPUSHs(sv_2mortal(newSViv(0)));
- RETURNOP(PL_op->op_next->op_next);
- }
- PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
- pp_pushmark(); /* push dst */
- pp_pushmark(); /* push src */
- ENTER; /* enter outer scope */
-
- SAVETMPS;
- /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
- SAVESPTR(DEFSV);
- ENTER; /* enter inner scope */
- SAVEVPTR(PL_curpm);
-
- src = PL_stack_base[*PL_markstack_ptr];
- SvTEMP_off(src);
- DEFSV = src;
-
- PUTBACK;
- if (PL_op->op_type == OP_MAPSTART)
- pp_pushmark(); /* push top */
- return ((LOGOP*)PL_op->op_next)->op_other;
-}
-
-PP(pp_mapstart)
-{
- DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
-}
-
-PP(pp_mapwhile)
-{
- dSP;
- I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
- I32 count;
- I32 shift;
- SV** src;
- SV** dst;
-
- /* first, move source pointer to the next item in the source list */
- ++PL_markstack_ptr[-1];
-
- /* if there are new items, push them into the destination list */
- if (items) {
- /* might need to make room back there first */
- if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
- /* XXX this implementation is very pessimal because the stack
- * is repeatedly extended for every set of items. Is possible
- * to do this without any stack extension or copying at all
- * by maintaining a separate list over which the map iterates
- * (like foreach does). --gsar */
-
- /* everything in the stack after the destination list moves
- * towards the end the stack by the amount of room needed */
- shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
-
- /* items to shift up (accounting for the moved source pointer) */
- count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
-
- /* This optimization is by Ben Tilly and it does
- * things differently from what Sarathy (gsar)
- * is describing. The downside of this optimization is
- * that leaves "holes" (uninitialized and hopefully unused areas)
- * to the Perl stack, but on the other hand this
- * shouldn't be a problem. If Sarathy's idea gets
- * implemented, this optimization should become
- * irrelevant. --jhi */
- if (shift < count)
- shift = count; /* Avoid shifting too often --Ben Tilly */
-
- EXTEND(SP,shift);
- src = SP;
- dst = (SP += shift);
- PL_markstack_ptr[-1] += shift;
- *PL_markstack_ptr += shift;
- while (count--)
- *dst-- = *src--;
- }
- /* copy the new items down to the destination list */
- dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
- while (items--)
- *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
- }
- LEAVE; /* exit inner scope */
-
- /* All done yet? */
- if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
- I32 gimme = GIMME_V;
-
- (void)POPMARK; /* pop top */
- LEAVE; /* exit outer scope */
- (void)POPMARK; /* pop src */
- items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
- (void)POPMARK; /* pop dst */
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (gimme == G_SCALAR) {
- dTARGET;
- XPUSHi(items);
- }
- else if (gimme == G_ARRAY)
- SP += items;
- RETURN;
- }
- else {
- SV *src;
-
- ENTER; /* enter inner scope */
- SAVEVPTR(PL_curpm);
-
- /* set $_ to the new source item */
- src = PL_stack_base[PL_markstack_ptr[-1]];
- SvTEMP_off(src);
- DEFSV = src;
-
- RETURNOP(cLOGOP->op_other);
- }
-}
-
-PP(pp_sort)
-{
- dSP; dMARK; dORIGMARK;
- register SV **up;
- SV **myorigmark = ORIGMARK;
- register I32 max;
- HV *stash;
- GV *gv;
- CV *cv;
- I32 gimme = GIMME;
- OP* nextop = PL_op->op_next;
- I32 overloading = 0;
- bool hasargs = FALSE;
- I32 is_xsub = 0;
-
- if (gimme != G_ARRAY) {
- SP = MARK;
- RETPUSHUNDEF;
- }
-
- ENTER;
- SAVEVPTR(PL_sortcop);
- if (PL_op->op_flags & OPf_STACKED) {
- if (PL_op->op_flags & OPf_SPECIAL) {
- OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
- kid = kUNOP->op_first; /* pass rv2gv */
- kid = kUNOP->op_first; /* pass leave */
- PL_sortcop = kid->op_next;
- stash = CopSTASH(PL_curcop);
- }
- else {
- cv = sv_2cv(*++MARK, &stash, &gv, 0);
- if (cv && SvPOK(cv)) {
- STRLEN n_a;
- char *proto = SvPV((SV*)cv, n_a);
- if (proto && strEQ(proto, "$$")) {
- hasargs = TRUE;
- }
- }
- if (!(cv && CvROOT(cv))) {
- if (cv && CvXSUB(cv)) {
- is_xsub = 1;
- }
- else if (gv) {
- SV *tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
- SvPVX(tmpstr));
- }
- else {
- DIE(aTHX_ "Undefined subroutine in sort");
- }
- }
-
- if (is_xsub)
- PL_sortcop = (OP*)cv;
- else {
- PL_sortcop = CvSTART(cv);
- SAVEVPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
- }
- }
- }
- else {
- PL_sortcop = Nullop;
- stash = CopSTASH(PL_curcop);
- }
-
- up = myorigmark + 1;
- while (MARK < SP) { /* This may or may not shift down one here. */
- /*SUPPRESS 560*/
- if ((*up = *++MARK)) { /* Weed out nulls. */
- SvTEMP_off(*up);
- if (!PL_sortcop && !SvPOK(*up)) {
- STRLEN n_a;
- if (SvAMAGIC(*up))
- overloading = 1;
- else
- (void)sv_2pv(*up, &n_a);
- }
- up++;
- }
- }
- max = --up - myorigmark;
- if (PL_sortcop) {
- if (max > 1) {
- PERL_CONTEXT *cx;
- SV** newsp;
- bool oldcatch = CATCH_GET;
-
- SAVETMPS;
- SAVEOP();
-
- CATCH_SET(TRUE);
- PUSHSTACKi(PERLSI_SORT);
- if (!hasargs && !is_xsub) {
- if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
- SAVESPTR(PL_firstgv);
- SAVESPTR(PL_secondgv);
- PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
- PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
- PL_sortstash = stash;
- }
-#ifdef USE_THREADS
- sv_lock((SV *)PL_firstgv);
- sv_lock((SV *)PL_secondgv);
-#endif
- SAVESPTR(GvSV(PL_firstgv));
- SAVESPTR(GvSV(PL_secondgv));
- }
-
- PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
- if (!(PL_op->op_flags & OPf_SPECIAL)) {
- cx->cx_type = CXt_SUB;
- cx->blk_gimme = G_SCALAR;
- PUSHSUB(cx);
- if (!CvDEPTH(cv))
- (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
- }
- PL_sortcxix = cxstack_ix;
-
- if (hasargs && !is_xsub) {
- /* This is mostly copied from pp_entersub */
- AV *av = (AV*)PL_curpad[0];
-
-#ifndef USE_THREADS
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
- cx->blk_sub.argarray = av;
- }
- qsortsv((myorigmark+1), max,
- is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
-
- POPBLOCK(cx,PL_curpm);
- PL_stack_sp = newsp;
- POPSTACK;
- CATCH_SET(oldcatch);
- }
- }
- else {
- if (max > 1) {
- MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsortsv(ORIGMARK+1, max,
- (PL_op->op_private & OPpSORT_NUMERIC)
- ? ( (PL_op->op_private & OPpSORT_INTEGER)
- ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
- : ( overloading ? amagic_ncmp : sv_ncmp))
- : ( (PL_op->op_private & OPpLOCALE)
- ? ( overloading
- ? amagic_cmp_locale
- : sv_cmp_locale_static)
- : ( overloading ? amagic_cmp : sv_cmp_static)));
- if (PL_op->op_private & OPpSORT_REVERSE) {
- SV **p = ORIGMARK+1;
- SV **q = ORIGMARK+max;
- while (p < q) {
- SV *tmp = *p;
- *p++ = *q;
- *q-- = tmp;
- }
- }
- }
- }
- LEAVE;
- PL_stack_sp = ORIGMARK + max;
- return nextop;
-}
-
-/* Range stuff. */
-
-PP(pp_range)
-{
- if (GIMME == G_ARRAY)
- return NORMAL;
- if (SvTRUEx(PAD_SV(PL_op->op_targ)))
- return cLOGOP->op_other;
- else
- return NORMAL;
-}
-
-PP(pp_flip)
-{
- dSP;
-
- if (GIMME == G_ARRAY) {
- RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
- }
- else {
- dTOPss;
- SV *targ = PAD_SV(PL_op->op_targ);
- int flip;
-
- if (PL_op->op_private & OPpFLIP_LINENUM) {
- struct io *gp_io;
- flip = PL_last_in_gv
- && (gp_io = GvIOp(PL_last_in_gv))
- && SvIV(sv) == (IV)IoLINES(gp_io);
- } else {
- flip = SvTRUE(sv);
- }
- if (flip) {
- sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
- if (PL_op->op_flags & OPf_SPECIAL) {
- sv_setiv(targ, 1);
- SETs(targ);
- RETURN;
- }
- else {
- sv_setiv(targ, 0);
- SP--;
- RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
- }
- }
- sv_setpv(TARG, "");
- SETs(targ);
- RETURN;
- }
-}
-
-PP(pp_flop)
-{
- dSP;
-
- if (GIMME == G_ARRAY) {
- dPOPPOPssrl;
- register I32 i, j;
- register SV *sv;
- I32 max;
-
- if (SvGMAGICAL(left))
- mg_get(left);
- if (SvGMAGICAL(right))
- mg_get(right);
-
- if (SvNIOKp(left) || !SvPOKp(left) ||
- SvNIOKp(right) || !SvPOKp(right) ||
- (looks_like_number(left) && *SvPVX(left) != '0' &&
- looks_like_number(right) && *SvPVX(right) != '0'))
- {
- if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
- DIE(aTHX_ "Range iterator outside integer range");
- i = SvIV(left);
- max = SvIV(right);
- if (max >= i) {
- j = max - i + 1;
- EXTEND_MORTAL(j);
- EXTEND(SP, j);
- }
- else
- j = 0;
- while (j--) {
- sv = sv_2mortal(newSViv(i++));
- PUSHs(sv);
- }
- }
- else {
- SV *final = sv_mortalcopy(right);
- STRLEN len, n_a;
- char *tmps = SvPV(final, len);
-
- sv = sv_mortalcopy(left);
- SvPV_force(sv,n_a);
- while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
- XPUSHs(sv);
- if (strEQ(SvPVX(sv),tmps))
- break;
- sv = sv_2mortal(newSVsv(sv));
- sv_inc(sv);
- }
- }
- }
- else {
- dTOPss;
- SV *targ = PAD_SV(cUNOP->op_first->op_targ);
- sv_inc(targ);
- if ((PL_op->op_private & OPpFLIP_LINENUM)
- ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
- : SvTRUE(sv) ) {
- sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
- sv_catpv(targ, "E0");
- }
- SETs(targ);
- }
-
- RETURN;
-}
-
-/* Control. */
-
-STATIC I32
-S_dopoptolabel(pTHX_ char *label)
-{
- register I32 i;
- register PERL_CONTEXT *cx;
-
- for (i = cxstack_ix; i >= 0; i--) {
- cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- case CXt_SUBST:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_SUB:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_FORMAT:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_EVAL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
- PL_op_name[PL_op->op_type]);
- return -1;
- case CXt_LOOP:
- if (!cx->blk_loop.label ||
- strNE(label, cx->blk_loop.label) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
- (long)i, cx->blk_loop.label));
- continue;
- }
- DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
- return i;
- }
- }
- return i;
-}
-
-I32
-Perl_dowantarray(pTHX)
-{
- I32 gimme = block_gimme();
- return (gimme == G_VOID) ? G_SCALAR : gimme;
-}
-
-I32
-Perl_block_gimme(pTHX)
-{
- I32 cxix;
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- return G_VOID;
-
- switch (cxstack[cxix].blk_gimme) {
- case G_VOID:
- return G_VOID;
- case G_SCALAR:
- return G_SCALAR;
- case G_ARRAY:
- return G_ARRAY;
- default:
- Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
- /* NOTREACHED */
- return 0;
- }
-}
-
-I32
-Perl_is_lvalue_sub(pTHX)
-{
- I32 cxix;
-
- cxix = dopoptosub(cxstack_ix);
- assert(cxix >= 0); /* We should only be called from inside subs */
-
- if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
- return cxstack[cxix].blk_sub.lval;
- else
- return 0;
-}
-
-STATIC I32
-S_dopoptosub(pTHX_ I32 startingblock)
-{
- return dopoptosub_at(cxstack, startingblock);
-}
-
-STATIC I32
-S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
-{
- I32 i;
- register PERL_CONTEXT *cx;
- for (i = startingblock; i >= 0; i--) {
- cx = &cxstk[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_EVAL:
- case CXt_SUB:
- case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
- return i;
- }
- }
- return i;
-}
-
-STATIC I32
-S_dopoptoeval(pTHX_ I32 startingblock)
-{
- I32 i;
- register PERL_CONTEXT *cx;
- for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
- return i;
- }
- }
- return i;
-}
-
-STATIC I32
-S_dopoptoloop(pTHX_ I32 startingblock)
-{
- I32 i;
- register PERL_CONTEXT *cx;
- for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- case CXt_SUBST:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_SUB:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_FORMAT:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_EVAL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
- PL_op_name[PL_op->op_type]);
- break;
- case CXt_NULL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
- PL_op_name[PL_op->op_type]);
- return -1;
- case CXt_LOOP:
- DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
- return i;
- }
- }
- return i;
-}
-
-void
-Perl_dounwind(pTHX_ I32 cxix)
-{
- register PERL_CONTEXT *cx;
- I32 optype;
-
- while (cxstack_ix > cxix) {
- SV *sv;
- cx = &cxstack[cxstack_ix];
- DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
- (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
- /* Note: we don't need to restore the base context info till the end. */
- switch (CxTYPE(cx)) {
- case CXt_SUBST:
- POPSUBST(cx);
- continue; /* not break */
- case CXt_SUB:
- POPSUB(cx,sv);
- LEAVESUB(sv);
- break;
- case CXt_EVAL:
- POPEVAL(cx);
- break;
- case CXt_LOOP:
- POPLOOP(cx);
- break;
- case CXt_NULL:
- break;
- case CXt_FORMAT:
- POPFORMAT(cx);
- break;
- }
- cxstack_ix--;
- }
-}
-
-void
-Perl_qerror(pTHX_ SV *err)
-{
- if (PL_in_eval)
- sv_catsv(ERRSV, err);
- else if (PL_errors)
- sv_catsv(PL_errors, err);
- else
- Perl_warn(aTHX_ "%"SVf, err);
- ++PL_error_count;
-}
-
-OP *
-Perl_die_where(pTHX_ char *message, STRLEN msglen)
-{
- STRLEN n_a;
- if (PL_in_eval) {
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
-
- if (message) {
- if (PL_in_eval & EVAL_KEEPERR) {
- static char prefix[] = "\t(in cleanup) ";
- SV *err = ERRSV;
- char *e = Nullch;
- if (!SvPOK(err))
- sv_setpv(err,"");
- else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
- e = SvPV(err, n_a);
- e += n_a - msglen;
- if (*e != *message || strNE(e,message))
- e = Nullch;
- }
- if (!e) {
- SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catpvn(err, message, msglen);
- if (ckWARN(WARN_MISC)) {
- STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
- }
- }
- }
- else
- sv_setpvn(ERRSV, message, msglen);
- }
- else
- message = SvPVx(ERRSV, msglen);
-
- while ((cxix = dopoptoeval(cxstack_ix)) < 0
- && PL_curstackinfo->si_prev)
- {
- dounwind(-1);
- POPSTACK;
- }
-
- if (cxix >= 0) {
- I32 optype;
-
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- POPBLOCK(cx,PL_curpm);
- if (CxTYPE(cx) != CXt_EVAL) {
- PerlIO_write(Perl_error_log, "panic: die ", 11);
- PerlIO_write(Perl_error_log, message, msglen);
- my_exit(1);
- }
- POPEVAL(cx);
-
- if (gimme == G_SCALAR)
- *++newsp = &PL_sv_undef;
- PL_stack_sp = newsp;
-
- LEAVE;
-
- /* LEAVE could clobber PL_curcop (see save_re_context())
- * XXX it might be better to find a way to avoid messing with
- * PL_curcop in save_re_context() instead, but this is a more
- * minimal fix --GSAR */
- PL_curcop = cx->blk_oldcop;
-
- if (optype == OP_REQUIRE) {
- char* msg = SvPVx(ERRSV, n_a);
- DIE(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
- }
- return pop_return();
- }
- }
- if (!message)
- message = SvPVx(ERRSV, msglen);
- {
-#ifdef USE_SFIO
- /* SFIO can really mess with your errno */
- int e = errno;
-#endif
- PerlIO *serr = Perl_error_log;
-
- PerlIO_write(serr, message, msglen);
- (void)PerlIO_flush(serr);
-#ifdef USE_SFIO
- errno = e;
-#endif
- }
- my_failure_exit();
- /* NOTREACHED */
- return 0;
-}
-
-PP(pp_xor)
-{
- dSP; dPOPTOPssrl;
- if (SvTRUE(left) != SvTRUE(right))
- RETSETYES;
- else
- RETSETNO;
-}
-
-PP(pp_andassign)
-{
- dSP;
- if (!SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_orassign)
-{
- dSP;
- if (SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_caller)
-{
- dSP;
- register I32 cxix = dopoptosub(cxstack_ix);
- register PERL_CONTEXT *cx;
- register PERL_CONTEXT *ccstack = cxstack;
- PERL_SI *top_si = PL_curstackinfo;
- I32 dbcxix;
- I32 gimme;
- char *stashname;
- SV *sv;
- I32 count = 0;
-
- if (MAXARG)
- count = POPi;
- EXTEND(SP, 10);
- for (;;) {
- /* we may be in a higher stacklevel, so dig down deeper */
- while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
- top_si = top_si->si_prev;
- ccstack = top_si->si_cxstack;
- cxix = dopoptosub_at(ccstack, top_si->si_cxix);
- }
- if (cxix < 0) {
- if (GIMME != G_ARRAY)
- RETPUSHUNDEF;
- RETURN;
- }
- if (PL_DBsub && cxix >= 0 &&
- ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
- count++;
- if (!count--)
- break;
- cxix = dopoptosub_at(ccstack, cxix - 1);
- }
-
- cx = &ccstack[cxix];
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- dbcxix = dopoptosub_at(ccstack, cxix - 1);
- /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
- field below is defined for any cx. */
- if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
- cx = &ccstack[dbcxix];
- }
-
- stashname = CopSTASHPV(cx->blk_oldcop);
- if (GIMME != G_ARRAY) {
- if (!stashname)
- PUSHs(&PL_sv_undef);
- else {
- dTARGET;
- sv_setpv(TARG, stashname);
- PUSHs(TARG);
- }
- RETURN;
- }
-
- if (!stashname)
- PUSHs(&PL_sv_undef);
- else
- PUSHs(sv_2mortal(newSVpv(stashname, 0)));
- PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
- PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
- if (!MAXARG)
- RETURN;
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- /* So is ccstack[dbcxix]. */
- sv = NEWSV(49, 0);
- gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
- PUSHs(sv_2mortal(sv));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
- }
- else {
- PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
- PUSHs(sv_2mortal(newSViv(0)));
- }
- gimme = (I32)cx->blk_gimme;
- if (gimme == G_VOID)
- PUSHs(&PL_sv_undef);
- else
- PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
- if (CxTYPE(cx) == CXt_EVAL) {
- /* eval STRING */
- if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
- PUSHs(cx->blk_eval.cur_text);
- PUSHs(&PL_sv_no);
- }
- /* require */
- else if (cx->blk_eval.old_namesv) {
- PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
- PUSHs(&PL_sv_yes);
- }
- /* eval BLOCK (try blocks have old_namesv == 0) */
- else {
- PUSHs(&PL_sv_undef);
- PUSHs(&PL_sv_undef);
- }
- }
- else {
- PUSHs(&PL_sv_undef);
- PUSHs(&PL_sv_undef);
- }
- if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
- && CopSTASH_eq(PL_curcop, PL_debstash))
- {
- AV *ary = cx->blk_sub.argarray;
- int off = AvARRAY(ary) - AvALLOC(ary);
-
- if (!PL_dbargs) {
- GV* tmpgv;
- PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
- SVt_PVAV)));
- GvMULTI_on(tmpgv);
- AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
- }
-
- if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
- av_extend(PL_dbargs, AvFILLp(ary) + off);
- Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
- AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
- }
- /* XXX only hints propagated via op_private are currently
- * visible (others are not easily accessible, since they
- * use the global PL_hints) */
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
- HINT_PRIVATE_MASK)));
- {
- SV * mask ;
- SV * old_warnings = cx->blk_oldcop->cop_warnings ;
-
- if (old_warnings == pWARN_NONE ||
- (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
- mask = newSVpvn(WARN_NONEstring, WARNsize) ;
- else if (old_warnings == pWARN_ALL ||
- (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
- mask = newSVpvn(WARN_ALLstring, WARNsize) ;
- else
- mask = newSVsv(old_warnings);
- PUSHs(sv_2mortal(mask));
- }
- RETURN;
-}
-
-PP(pp_reset)
-{
- dSP;
- char *tmps;
- STRLEN n_a;
-
- if (MAXARG < 1)
- tmps = "";
- else
- tmps = POPpx;
- sv_reset(tmps, CopSTASH(PL_curcop));
- PUSHs(&PL_sv_yes);
- RETURN;
-}
-
-PP(pp_lineseq)
-{
- return NORMAL;
-}
-
-PP(pp_dbstate)
-{
- PL_curcop = (COP*)PL_op;
- TAINT_NOT; /* Each statement is presumed innocent */
- PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
- FREETMPS;
-
- if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
- {
- dSP;
- register CV *cv;
- register PERL_CONTEXT *cx;
- I32 gimme = G_ARRAY;
- I32 hasargs;
- GV *gv;
-
- gv = PL_DBgv;
- cv = GvCV(gv);
- if (!cv)
- DIE(aTHX_ "No DB::DB routine defined");
-
- if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
- return NORMAL;
-
- ENTER;
- SAVETMPS;
-
- SAVEI32(PL_debug);
- SAVESTACK_POS();
- PL_debug = 0;
- hasargs = 0;
- SPAGAIN;
-
- push_return(PL_op->op_next);
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
- CvDEPTH(cv)++;
- (void)SvREFCNT_inc(cv);
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
- RETURNOP(CvSTART(cv));
- }
- else
- return NORMAL;
-}
-
-PP(pp_scope)
-{
- return NORMAL;
-}
-
-PP(pp_enteriter)
-{
- dSP; dMARK;
- register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
- SV **svp;
- U32 cxtype = CXt_LOOP;
-#ifdef USE_ITHREADS
- void *iterdata;
-#endif
-
- ENTER;
- SAVETMPS;
-
-#ifdef USE_THREADS
- if (PL_op->op_flags & OPf_SPECIAL) {
- svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
- SAVEGENERICSV(*svp);
- *svp = NEWSV(0,0);
- }
- else
-#endif /* USE_THREADS */
- if (PL_op->op_targ) {
-#ifndef USE_ITHREADS
- svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
- SAVESPTR(*svp);
-#else
- SAVEPADSV(PL_op->op_targ);
- iterdata = (void*)PL_op->op_targ;
- cxtype |= CXp_PADVAR;
-#endif
- }
- else {
- GV *gv = (GV*)POPs;
- svp = &GvSV(gv); /* symbol table variable */
- SAVEGENERICSV(*svp);
- *svp = NEWSV(0,0);
-#ifdef USE_ITHREADS
- iterdata = (void*)gv;
-#endif
- }
-
- ENTER;
-
- PUSHBLOCK(cx, cxtype, SP);
-#ifdef USE_ITHREADS
- PUSHLOOP(cx, iterdata, MARK);
-#else
- PUSHLOOP(cx, svp, MARK);
-#endif
- if (PL_op->op_flags & OPf_STACKED) {
- cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
- if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
- dPOPss;
- if (SvNIOKp(sv) || !SvPOKp(sv) ||
- SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
- (looks_like_number(sv) && *SvPVX(sv) != '0' &&
- looks_like_number((SV*)cx->blk_loop.iterary) &&
- *SvPVX(cx->blk_loop.iterary) != '0'))
- {
- if (SvNV(sv) < IV_MIN ||
- SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
- DIE(aTHX_ "Range iterator outside integer range");
- cx->blk_loop.iterix = SvIV(sv);
- cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
- }
- else
- cx->blk_loop.iterlval = newSVsv(sv);
- }
- }
- else {
- cx->blk_loop.iterary = PL_curstack;
- AvFILLp(PL_curstack) = SP - PL_stack_base;
- cx->blk_loop.iterix = MARK - PL_stack_base;
- }
-
- RETURN;
-}
-
-PP(pp_enterloop)
-{
- dSP;
- register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
-
- ENTER;
- SAVETMPS;
- ENTER;
-
- PUSHBLOCK(cx, CXt_LOOP, SP);
- PUSHLOOP(cx, 0, SP);
-
- RETURN;
-}
-
-PP(pp_leaveloop)
-{
- dSP;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
- SV **mark;
-
- POPBLOCK(cx,newpm);
- mark = newsp;
- newsp = PL_stack_base + cx->blk_loop.resetsp;
-
- TAINT_NOT;
- if (gimme == G_VOID)
- ; /* do nothing */
- else if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &PL_sv_undef;
- }
- else {
- while (mark < SP) {
- *++newsp = sv_mortalcopy(*++mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- SP = newsp;
- PUTBACK;
-
- POPLOOP(cx); /* Stack values are safe: release loop vars ... */
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVE;
- LEAVE;
-
- return NORMAL;
-}
-
-PP(pp_return)
-{
- dSP; dMARK;
- I32 cxix;
- register PERL_CONTEXT *cx;
- bool popsub2 = FALSE;
- bool clear_errsv = FALSE;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
- I32 optype = 0;
- SV *sv;
-
- if (PL_curstackinfo->si_type == PERLSI_SORT) {
- if (cxstack_ix == PL_sortcxix
- || dopoptosub(cxstack_ix) <= PL_sortcxix)
- {
- if (cxstack_ix > PL_sortcxix)
- dounwind(PL_sortcxix);
- AvARRAY(PL_curstack)[1] = *SP;
- PL_stack_sp = PL_stack_base + 1;
- return 0;
- }
- }
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't return outside a subroutine");
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- POPBLOCK(cx,newpm);
- switch (CxTYPE(cx)) {
- case CXt_SUB:
- popsub2 = TRUE;
- break;
- case CXt_EVAL:
- if (!(PL_in_eval & EVAL_KEEPERR))
- clear_errsv = TRUE;
- POPEVAL(cx);
- if (CxTRYBLOCK(cx))
- break;
- lex_end();
- if (optype == OP_REQUIRE &&
- (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
- {
- /* Unassume the success we assumed earlier. */
- SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
- }
- break;
- case CXt_FORMAT:
- POPFORMAT(cx);
- break;
- default:
- DIE(aTHX_ "panic: return");
- }
-
- TAINT_NOT;
- if (gimme == G_SCALAR) {
- if (MARK < SP) {
- if (popsub2) {
- if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
- *++newsp = SvREFCNT_inc(*SP);
- FREETMPS;
- sv_2mortal(*newsp);
- }
- else {
- sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
- FREETMPS;
- *++newsp = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
- }
- }
- else
- *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
- }
- else
- *++newsp = sv_mortalcopy(*SP);
- }
- else
- *++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = (popsub2 && SvTEMP(*MARK))
- ? *MARK : sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- PL_stack_sp = newsp;
-
- /* Stack values are safe: */
- if (popsub2) {
- POPSUB(cx,sv); /* release CV and @_ ... */
- }
- else
- sv = Nullsv;
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVE;
- LEAVESUB(sv);
- if (clear_errsv)
- sv_setpv(ERRSV,"");
- return pop_return();
-}
-
-PP(pp_last)
-{
- dSP;
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 pop2 = 0;
- I32 gimme;
- I32 optype;
- OP *nextop;
- SV **newsp;
- PMOP *newpm;
- SV **mark;
- SV *sv = Nullsv;
-
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"last\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- POPBLOCK(cx,newpm);
- mark = newsp;
- switch (CxTYPE(cx)) {
- case CXt_LOOP:
- pop2 = CXt_LOOP;
- newsp = PL_stack_base + cx->blk_loop.resetsp;
- nextop = cx->blk_loop.last_op->op_next;
- break;
- case CXt_SUB:
- pop2 = CXt_SUB;
- nextop = pop_return();
- break;
- case CXt_EVAL:
- POPEVAL(cx);
- nextop = pop_return();
- break;
- case CXt_FORMAT:
- POPFORMAT(cx);
- nextop = pop_return();
- break;
- default:
- DIE(aTHX_ "panic: last");
- }
-
- TAINT_NOT;
- if (gimme == G_SCALAR) {
- if (MARK < SP)
- *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
- ? *SP : sv_mortalcopy(*SP);
- else
- *++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
- ? *MARK : sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- SP = newsp;
- PUTBACK;
-
- /* Stack values are safe: */
- switch (pop2) {
- case CXt_LOOP:
- POPLOOP(cx); /* release loop vars ... */
- LEAVE;
- break;
- case CXt_SUB:
- POPSUB(cx,sv); /* release CV and @_ ... */
- break;
- }
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVE;
- LEAVESUB(sv);
- return nextop;
-}
-
-PP(pp_next)
-{
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 inner;
-
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"next\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- /* clear off anything above the scope we're re-entering, but
- * save the rest until after a possible continue block */
- inner = PL_scopestack_ix;
- TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
- return cx->blk_loop.next_op;
-}
-
-PP(pp_redo)
-{
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 oldsave;
-
- if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't \"redo\" outside a loop block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- TOPBLOCK(cx);
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- return cx->blk_loop.redo_op;
-}
-
-STATIC OP *
-S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
-{
- OP *kid;
- OP **ops = opstack;
- static char too_deep[] = "Target of goto is too deeply nested";
-
- if (ops >= oplimit)
- Perl_croak(aTHX_ too_deep);
- if (o->op_type == OP_LEAVE ||
- o->op_type == OP_SCOPE ||
- o->op_type == OP_LEAVELOOP ||
- o->op_type == OP_LEAVETRY)
- {
- *ops++ = cUNOPo->op_first;
- if (ops >= oplimit)
- Perl_croak(aTHX_ too_deep);
- }
- *ops = 0;
- if (o->op_flags & OPf_KIDS) {
- /* First try all the kids at this level, since that's likeliest. */
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- kCOP->cop_label && strEQ(kCOP->cop_label, label))
- return kid;
- }
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid == PL_lastgotoprobe)
- continue;
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- (ops == opstack ||
- (ops[-1]->op_type != OP_NEXTSTATE &&
- ops[-1]->op_type != OP_DBSTATE)))
- *ops++ = kid;
- if ((o = dofindlabel(kid, label, ops, oplimit)))
- return o;
- }
- }
- *ops = 0;
- return 0;
-}
-
-PP(pp_dump)
-{
- return pp_goto();
- /*NOTREACHED*/
-}
-
-PP(pp_goto)
-{
- dSP;
- OP *retop = 0;
- I32 ix;
- register PERL_CONTEXT *cx;
-#define GOTO_DEPTH 64
- OP *enterops[GOTO_DEPTH];
- char *label;
- int do_dump = (PL_op->op_type == OP_DUMP);
- static char must_have_label[] = "goto must have label";
-
- label = 0;
- if (PL_op->op_flags & OPf_STACKED) {
- SV *sv = POPs;
- STRLEN n_a;
-
- /* This egregious kludge implements goto &subroutine */
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
- I32 cxix;
- register PERL_CONTEXT *cx;
- CV* cv = (CV*)SvRV(sv);
- SV** mark;
- I32 items = 0;
- I32 oldsave;
-
- retry:
- if (!CvROOT(cv) && !CvXSUB(cv)) {
- GV *gv = CvGV(cv);
- GV *autogv;
- if (gv) {
- SV *tmpstr;
- /* autoloaded stub? */
- if (cv != GvCV(gv) && (cv = GvCV(gv)))
- goto retry;
- autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
- GvNAMELEN(gv), FALSE);
- if (autogv && (cv = GvCV(autogv)))
- goto retry;
- tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
- }
- DIE(aTHX_ "Goto undefined subroutine");
- }
-
- /* First do some returnish stuff. */
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't goto subroutine outside a subroutine");
- if (cxix < cxstack_ix)
- dounwind(cxix);
- TOPBLOCK(cx);
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
- DIE(aTHX_ "Can't goto subroutine from an eval-string");
- mark = PL_stack_sp;
- if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
- /* put @_ back onto stack */
- AV* av = cx->blk_sub.argarray;
-
- items = AvFILLp(av) + 1;
- PL_stack_sp++;
- EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
- Copy(AvARRAY(av), PL_stack_sp, items, SV*);
- PL_stack_sp += items;
-#ifndef USE_THREADS
- SvREFCNT_dec(GvAV(PL_defgv));
- GvAV(PL_defgv) = cx->blk_sub.savearray;
-#endif /* USE_THREADS */
- /* abandon @_ if it got reified */
- if (AvREAL(av)) {
- (void)sv_2mortal((SV*)av); /* delay until return */
- av = newAV();
- av_extend(av, items-1);
- AvFLAGS(av) = AVf_REIFY;
- PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
- }
- }
- else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
- AV* av;
-#ifdef USE_THREADS
- av = (AV*)PL_curpad[0];
-#else
- av = GvAV(PL_defgv);
-#endif
- items = AvFILLp(av) + 1;
- PL_stack_sp++;
- EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
- Copy(AvARRAY(av), PL_stack_sp, items, SV*);
- PL_stack_sp += items;
- }
- if (CxTYPE(cx) == CXt_SUB &&
- !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
- SvREFCNT_dec(cx->blk_sub.cv);
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
-
- /* Now do some callish stuff. */
- SAVETMPS;
- if (CvXSUB(cv)) {
-#ifdef PERL_XSUB_OLDSTYLE
- if (CvOLDSTYLE(cv)) {
- I32 (*fp3)(int,int,int);
- while (SP > mark) {
- SP[1] = SP[0];
- SP--;
- }
- fp3 = (I32(*)(int,int,int))CvXSUB(cv);
- items = (*fp3)(CvXSUBANY(cv).any_i32,
- mark - PL_stack_base + 1,
- items);
- SP = PL_stack_base + items;
- }
- else
-#endif /* PERL_XSUB_OLDSTYLE */
- {
- SV **newsp;
- I32 gimme;
-
- PL_stack_sp--; /* There is no cv arg. */
- /* Push a mark for the start of arglist */
- PUSHMARK(mark);
- (void)(*CvXSUB(cv))(aTHXo_ cv);
- /* Pop the current context like a decent sub should */
- POPBLOCK(cx, PL_curpm);
- /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
- }
- LEAVE;
- return pop_return();
- }
- else {
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
- if (CxTYPE(cx) == CXt_EVAL) {
- PL_in_eval = cx->blk_eval.old_in_eval;
- PL_eval_root = cx->blk_eval.old_eval_root;
- cx->cx_type = CXt_SUB;
- cx->blk_sub.hasargs = 0;
- }
- cx->blk_sub.cv = cv;
- cx->blk_sub.olddepth = CvDEPTH(cv);
- CvDEPTH(cv)++;
- if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
- else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
- sub_crush_depth(cv);
- if (CvDEPTH(cv) > AvFILLp(padlist)) {
- AV *newpad = newAV();
- SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
- svp = AvARRAY(svp[0]);
- for ( ;ix > 0; ix--) {
- if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
- char *name = SvPVX(svp[ix]);
- if ((SvFLAGS(svp[ix]) & SVf_FAKE)
- || *name == '&')
- {
- /* outer lexical or anon code */
- av_store(newpad, ix,
- SvREFCNT_inc(oldpad[ix]) );
- }
- else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
- else
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADMY_on(sv);
- }
- }
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
- }
- else {
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADTMP_on(sv);
- }
- }
- if (cx->blk_sub.hasargs) {
- AV* av = newAV();
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- }
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILLp(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
- }
-#ifdef USE_THREADS
- if (!cx->blk_sub.hasargs) {
- AV* av = (AV*)PL_curpad[0];
-
- items = AvFILLp(av) + 1;
- if (items) {
- /* Mark is at the end of the stack. */
- EXTEND(SP, items);
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SP += items;
- PUTBACK ;
- }
- }
-#endif /* USE_THREADS */
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_THREADS
- if (cx->blk_sub.hasargs)
-#endif /* USE_THREADS */
- {
- AV* av = (AV*)PL_curpad[0];
- SV** ary;
-
-#ifndef USE_THREADS
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
- cx->blk_sub.argarray = av;
- ++mark;
-
- if (items >= AvMAX(av) + 1) {
- ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
- }
- if (items >= AvMAX(av) + 1) {
- AvMAX(av) = items - 1;
- Renew(ary,items+1,SV*);
- AvALLOC(av) = ary;
- SvPVX(av) = (char*)ary;
- }
- }
- Copy(mark,AvARRAY(av),items,SV*);
- AvFILLp(av) = items - 1;
- assert(!AvREAL(av));
- while (items--) {
- if (*mark)
- SvTEMP_off(*mark);
- mark++;
- }
- }
- if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
- /*
- * We do not care about using sv to call CV;
- * it's for informational purposes only.
- */
- SV *sv = GvSV(PL_DBsub);
- CV *gotocv;
-
- if (PERLDB_SUB_NN) {
- SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
- } else {
- save_item(sv);
- gv_efullname3(sv, CvGV(cv), Nullch);
- }
- if ( PERLDB_GOTO
- && (gotocv = get_cv("DB::goto", FALSE)) ) {
- PUSHMARK( PL_stack_sp );
- call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
- PL_stack_sp--;
- }
- }
- RETURNOP(CvSTART(cv));
- }
- }
- else {
- label = SvPV(sv,n_a);
- if (!(do_dump || *label))
- DIE(aTHX_ must_have_label);
- }
- }
- else if (PL_op->op_flags & OPf_SPECIAL) {
- if (! do_dump)
- DIE(aTHX_ must_have_label);
- }
- else
- label = cPVOP->op_pv;
-
- if (label && *label) {
- OP *gotoprobe = 0;
-
- /* find label */
-
- PL_lastgotoprobe = 0;
- *enterops = 0;
- for (ix = cxstack_ix; ix >= 0; ix--) {
- cx = &cxstack[ix];
- switch (CxTYPE(cx)) {
- case CXt_EVAL:
- gotoprobe = PL_eval_root; /* XXX not good for nested eval */
- break;
- case CXt_LOOP:
- gotoprobe = cx->blk_oldcop->op_sibling;
- break;
- case CXt_SUBST:
- continue;
- case CXt_BLOCK:
- if (ix)
- gotoprobe = cx->blk_oldcop->op_sibling;
- else
- gotoprobe = PL_main_root;
- break;
- case CXt_SUB:
- if (CvDEPTH(cx->blk_sub.cv)) {
- gotoprobe = CvROOT(cx->blk_sub.cv);
- break;
- }
- /* FALL THROUGH */
- case CXt_FORMAT:
- case CXt_NULL:
- DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
- default:
- if (ix)
- DIE(aTHX_ "panic: goto");
- gotoprobe = PL_main_root;
- break;
- }
- if (gotoprobe) {
- retop = dofindlabel(gotoprobe, label,
- enterops, enterops + GOTO_DEPTH);
- if (retop)
- break;
- }
- PL_lastgotoprobe = gotoprobe;
- }
- if (!retop)
- DIE(aTHX_ "Can't find label %s", label);
-
- /* pop unwanted frames */
-
- if (ix < cxstack_ix) {
- I32 oldsave;
-
- if (ix < 0)
- ix = 0;
- dounwind(ix);
- TOPBLOCK(cx);
- oldsave = PL_scopestack[PL_scopestack_ix];
- LEAVE_SCOPE(oldsave);
- }
-
- /* push wanted frames */
-
- if (*enterops && enterops[1]) {
- OP *oldop = PL_op;
- for (ix = 1; enterops[ix]; ix++) {
- PL_op = enterops[ix];
- /* Eventually we may want to stack the needed arguments
- * for each op. For now, we punt on the hard ones. */
- if (PL_op->op_type == OP_ENTERITER)
- DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
- CALL_FPTR(PL_op->op_ppaddr)(aTHX);
- }
- PL_op = oldop;
- }
- }
-
- if (do_dump) {
-#ifdef VMS
- if (!retop) retop = PL_main_start;
-#endif
- PL_restartop = retop;
- PL_do_undump = TRUE;
-
- my_unexec();
-
- PL_restartop = 0; /* hmm, must be GNU unexec().. */
- PL_do_undump = FALSE;
- }
-
- RETURNOP(retop);
-}
-
-PP(pp_exit)
-{
- dSP;
- I32 anum;
-
- if (MAXARG < 1)
- anum = 0;
- else {
- anum = SvIVx(POPs);
-#ifdef VMS
- if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
- anum = 0;
-#endif
- }
- PL_exit_flags |= PERL_EXIT_EXPECTED;
- my_exit(anum);
- PUSHs(&PL_sv_undef);
- RETURN;
-}
-
-#ifdef NOTYET
-PP(pp_nswitch)
-{
- dSP;
- NV value = SvNVx(GvSV(cCOP->cop_gv));
- register I32 match = I_32(value);
-
- if (value < 0.0) {
- if (((NV)match) > value)
- --match; /* was fractional--truncate other way */
- }
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- PL_op = cCOP->uop.scop.scop_next[match];
- RETURNOP(PL_op);
-}
-
-PP(pp_cswitch)
-{
- dSP;
- register I32 match;
-
- if (PL_multiline)
- PL_op = PL_op->op_next; /* can't assume anything */
- else {
- STRLEN n_a;
- match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- PL_op = cCOP->uop.scop.scop_next[match];
- }
- RETURNOP(PL_op);
-}
-#endif
-
-/* Eval. */
-
-STATIC void
-S_save_lines(pTHX_ AV *array, SV *sv)
-{
- register char *s = SvPVX(sv);
- register char *send = SvPVX(sv) + SvCUR(sv);
- register char *t;
- register I32 line = 1;
-
- while (s && s < send) {
- SV *tmpstr = NEWSV(85,0);
-
- sv_upgrade(tmpstr, SVt_PVMG);
- t = strchr(s, '\n');
- if (t)
- t++;
- else
- t = send;
-
- sv_setpvn(tmpstr, s, t - s);
- av_store(array, line++, tmpstr);
- s = t;
- }
-}
-
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_docatch_body(pTHX_ va_list args)
-{
- return docatch_body();
-}
-#endif
-
-STATIC void *
-S_docatch_body(pTHX)
-{
- CALLRUNOPS(aTHX);
- return NULL;
-}
-
-STATIC OP *
-S_docatch(pTHX_ OP *o)
-{
- int ret;
- OP *oldop = PL_op;
- volatile PERL_SI *cursi = PL_curstackinfo;
- dJMPENV;
-
-#ifdef DEBUGGING
- assert(CATCH_GET == TRUE);
-#endif
- PL_op = o;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
-#else
- JMPENV_PUSH(ret);
-#endif
- switch (ret) {
- case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- docatch_body();
-#endif
- break;
- case 3:
- if (PL_restartop && cursi == PL_curstackinfo) {
- PL_op = PL_restartop;
- PL_restartop = 0;
- goto redo_body;
- }
- /* FALL THROUGH */
- default:
- JMPENV_POP;
- PL_op = oldop;
- JMPENV_JUMP(ret);
- /* NOTREACHED */
- }
- JMPENV_POP;
- PL_op = oldop;
- return Nullop;
-}
-
-OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
-/* sv Text to convert to OP tree. */
-/* startop op_free() this to undo. */
-/* code Short string id of the caller. */
-{
- dSP; /* Make POPBLOCK work. */
- PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
- I32 optype;
- OP dummy;
- OP *rop;
- char tbuf[TYPE_DIGITS(long) + 12 + 10];
- char *tmpbuf = tbuf;
- char *safestr;
-
- ENTER;
- lex_start(sv);
- SAVETMPS;
- /* switch to eval mode */
-
- if (PL_curcop == &PL_compiling) {
- SAVECOPSTASH_FREE(&PL_compiling);
- CopSTASH_set(&PL_compiling, PL_curstash);
- }
- if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV *sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
- code, (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- }
- else
- sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tmpbuf+2);
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepv(tmpbuf);
- SAVEDELETE(PL_defstash, safestr, strlen(safestr));
- SAVEHINTS();
-#ifdef OP_IN_REGISTER
- PL_opsave = op;
-#else
- SAVEVPTR(PL_op);
-#endif
- PL_hints = 0;
-
- PL_op = &dummy;
- PL_op->op_type = OP_ENTEREVAL;
- PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0, Nullgv);
- rop = doeval(G_SCALAR, startop);
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
-
- (*startop)->op_type = OP_NULL;
- (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- lex_end();
- *avp = (AV*)SvREFCNT_inc(PL_comppad);
- LEAVE;
- if (PL_curcop == &PL_compiling)
- PL_compiling.op_private = PL_hints;
-#ifdef OP_IN_REGISTER
- op = PL_opsave;
-#endif
- return rop;
-}
-
-/* With USE_THREADS, eval_owner must be held on entry to doeval */
-STATIC OP *
-S_doeval(pTHX_ int gimme, OP** startop)
-{
- dSP;
- OP *saveop = PL_op;
- CV *caller;
- AV* comppadlist;
- I32 i;
-
- PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
- ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
- : EVAL_INEVAL);
-
- PUSHMARK(SP);
-
- /* set up a scratch pad */
-
- SAVEI32(PL_padix);
- SAVEVPTR(PL_curpad);
- SAVESPTR(PL_comppad);
- SAVESPTR(PL_comppad_name);
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
-
- caller = PL_compcv;
- for (i = cxstack_ix - 1; i >= 0; i--) {
- PERL_CONTEXT *cx = &cxstack[i];
- if (CxTYPE(cx) == CXt_EVAL)
- break;
- else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- caller = cx->blk_sub.cv;
- break;
- }
- }
-
- SAVESPTR(PL_compcv);
- PL_compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)PL_compcv, SVt_PVCV);
- CvEVAL_on(PL_compcv);
-#ifdef USE_THREADS
- CvOWNER(PL_compcv) = 0;
- New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_THREADS */
-
- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
-#ifdef USE_THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
-#endif /* USE_THREADS */
-
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(PL_compcv) = comppadlist;
-
- if (!saveop ||
- (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
- {
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
- }
-
- SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
-
- /* make sure we compile in the right package */
-
- if (CopSTASH_ne(PL_curcop, PL_curstash)) {
- SAVESPTR(PL_curstash);
- PL_curstash = CopSTASH(PL_curcop);
- }
- SAVESPTR(PL_beginav);
- PL_beginav = newAV();
- SAVEFREESV(PL_beginav);
- SAVEI32(PL_error_count);
-
- /* try to compile it */
-
- PL_eval_root = Nullop;
- PL_error_count = 0;
- PL_curcop = &PL_compiling;
- PL_curcop->cop_arybase = 0;
- SvREFCNT_dec(PL_rs);
- PL_rs = newSVpvn("\n", 1);
- if (saveop && saveop->op_flags & OPf_SPECIAL)
- PL_in_eval |= EVAL_KEEPERR;
- else
- sv_setpv(ERRSV,"");
- if (yyparse() || PL_error_count || !PL_eval_root) {
- SV **newsp;
- I32 gimme;
- PERL_CONTEXT *cx;
- I32 optype = 0; /* Might be reset by POPEVAL. */
- STRLEN n_a;
-
- PL_op = saveop;
- if (PL_eval_root) {
- op_free(PL_eval_root);
- PL_eval_root = Nullop;
- }
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- pop_return();
- }
- lex_end();
- LEAVE;
- if (optype == OP_REQUIRE) {
- char* msg = SvPVx(ERRSV, n_a);
- DIE(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
- }
- else if (startop) {
- char* msg = SvPVx(ERRSV, n_a);
-
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
- Perl_croak(aTHX_ "%sCompilation failed in regexp",
- (*msg ? msg : "Unknown error\n"));
- }
- SvREFCNT_dec(PL_rs);
- PL_rs = SvREFCNT_inc(PL_nrs);
-#ifdef USE_THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- PL_eval_owner = 0;
- COND_SIGNAL(&PL_eval_cond);
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
- RETPUSHUNDEF;
- }
- SvREFCNT_dec(PL_rs);
- PL_rs = SvREFCNT_inc(PL_nrs);
- CopLINE_set(&PL_compiling, 0);
- if (startop) {
- *startop = PL_eval_root;
- SvREFCNT_dec(CvOUTSIDE(PL_compcv));
- CvOUTSIDE(PL_compcv) = Nullcv;
- } else
- SAVEFREEOP(PL_eval_root);
- if (gimme & G_VOID)
- scalarvoid(PL_eval_root);
- else if (gimme & G_ARRAY)
- list(PL_eval_root);
- else
- scalar(PL_eval_root);
-
- DEBUG_x(dump_eval());
-
- /* Register with debugger: */
- if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
- CV *cv = get_cv("DB::postponed", FALSE);
- if (cv) {
- dSP;
- PUSHMARK(SP);
- XPUSHs((SV*)CopFILEGV(&PL_compiling));
- PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
- }
- }
-
- /* compiled okay, so do it */
-
- CvDEPTH(PL_compcv) = 1;
- SP = PL_stack_base + POPMARK; /* pop original mark */
- PL_op = saveop; /* The caller may need it. */
- PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
-#ifdef USE_THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- PL_eval_owner = 0;
- COND_SIGNAL(&PL_eval_cond);
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
-
- RETURNOP(PL_eval_start);
-}
-
-STATIC PerlIO *
-S_doopen_pmc(pTHX_ const char *name, const char *mode)
-{
- STRLEN namelen = strlen(name);
- PerlIO *fp;
-
- if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
- SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
- char *pmc = SvPV_nolen(pmcsv);
- Stat_t pmstat;
- Stat_t pmcstat;
- if (PerlLIO_stat(pmc, &pmcstat) < 0) {
- fp = PerlIO_open(name, mode);
- }
- else {
- if (PerlLIO_stat(name, &pmstat) < 0 ||
- pmstat.st_mtime < pmcstat.st_mtime)
- {
- fp = PerlIO_open(pmc, mode);
- }
- else {
- fp = PerlIO_open(name, mode);
- }
- }
- SvREFCNT_dec(pmcsv);
- }
- else {
- fp = PerlIO_open(name, mode);
- }
- return fp;
-}
-
-PP(pp_require)
-{
- dSP;
- register PERL_CONTEXT *cx;
- SV *sv;
- char *name;
- STRLEN len;
- char *tryname;
- SV *namesv = Nullsv;
- SV** svp;
- I32 gimme = G_SCALAR;
- PerlIO *tryrsfp = 0;
- STRLEN n_a;
- int filter_has_file = 0;
- GV *filter_child_proc = 0;
- SV *filter_state = 0;
- SV *filter_sub = 0;
-
- sv = POPs;
- if (SvNIOKp(sv)) {
- if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
- UV rev = 0, ver = 0, sver = 0;
- STRLEN len;
- U8 *s = (U8*)SvPVX(sv);
- U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
- if (s < end) {
- rev = utf8_to_uv(s, end - s, &len, 0);
- s += len;
- if (s < end) {
- ver = utf8_to_uv(s, end - s, &len, 0);
- s += len;
- if (s < end)
- sver = utf8_to_uv(s, end - s, &len, 0);
- }
- }
- if (PERL_REVISION < rev
- || (PERL_REVISION == rev
- && (PERL_VERSION < ver
- || (PERL_VERSION == ver
- && PERL_SUBVERSION < sver))))
- {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
- "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
- PERL_VERSION, PERL_SUBVERSION);
- }
- RETPUSHYES;
- }
- else if (!SvPOKp(sv)) { /* require 5.005_03 */
- if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
- + ((NV)PERL_SUBVERSION/(NV)1000000)
- + 0.00000099 < SvNV(sv))
- {
- NV nrev = SvNV(sv);
- UV rev = (UV)nrev;
- NV nver = (nrev - rev) * 1000;
- UV ver = (UV)(nver + 0.0009);
- NV nsver = (nver - ver) * 1000;
- UV sver = (UV)(nsver + 0.0009);
-
- /* help out with the "use 5.6" confusion */
- if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
- "this is only v%d.%d.%d, stopped"
- " (did you mean v%"UVuf".%"UVuf".0?)",
- rev, ver, sver, PERL_REVISION, PERL_VERSION,
- PERL_SUBVERSION, rev, ver/100);
- }
- else {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
- "this is only v%d.%d.%d, stopped",
- rev, ver, sver, PERL_REVISION, PERL_VERSION,
- PERL_SUBVERSION);
- }
- }
- RETPUSHYES;
- }
- }
- name = SvPV(sv, len);
- if (!(name && len > 0 && *name))
- DIE(aTHX_ "Null filename used");
- TAINT_PROPER("require");
- if (PL_op->op_type == OP_REQUIRE &&
- (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
- *svp != &PL_sv_undef)
- RETPUSHYES;
-
- /* prepare to compile file */
-
-#ifdef MACOS_TRADITIONAL
- if (PERL_FILE_IS_ABSOLUTE(name)
- || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
- {
- tryname = name;
- tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
- /* We consider paths of the form :a:b ambiguous and interpret them first
- as global then as local
- */
- if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
- goto trylocal;
- }
- else
-trylocal: {
-#else
- if (PERL_FILE_IS_ABSOLUTE(name)
- || (*name == '.' && (name[1] == '/' ||
- (name[1] == '.' && name[2] == '/'))))
- {
- tryname = name;
- tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
- }
- else {
-#endif
- AV *ar = GvAVn(PL_incgv);
- I32 i;
-#ifdef VMS
- char *unixname;
- if ((unixname = tounixspec(name, Nullch)) != Nullch)
-#endif
- {
- namesv = NEWSV(806, 0);
- for (i = 0; i <= AvFILL(ar); i++) {
- SV *dirsv = *av_fetch(ar, i, TRUE);
-
- if (SvROK(dirsv)) {
- int count;
- SV *loader = dirsv;
-
- if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
- loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
- }
-
- Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
- PTR2UV(SvANY(loader)), name);
- tryname = SvPVX(namesv);
- tryrsfp = 0;
-
- ENTER;
- SAVETMPS;
- EXTEND(SP, 2);
-
- PUSHMARK(SP);
- PUSHs(dirsv);
- PUSHs(sv);
- PUTBACK;
- if (sv_isobject(loader))
- count = call_method("INC", G_ARRAY);
- else
- count = call_sv(loader, G_ARRAY);
- SPAGAIN;
-
- if (count > 0) {
- int i = 0;
- SV *arg;
-
- SP -= count - 1;
- arg = SP[i++];
-
- if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
- arg = SvRV(arg);
- }
-
- if (SvTYPE(arg) == SVt_PVGV) {
- IO *io = GvIO((GV *)arg);
-
- ++filter_has_file;
-
- if (io) {
- tryrsfp = IoIFP(io);
- if (IoTYPE(io) == IoTYPE_PIPE) {
- /* reading from a child process doesn't
- nest -- when returning from reading
- the inner module, the outer one is
- unreadable (closed?) I've tried to
- save the gv to manage the lifespan of
- the pipe, but this didn't help. XXX */
- filter_child_proc = (GV *)arg;
- (void)SvREFCNT_inc(filter_child_proc);
- }
- else {
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
- PerlIO_close(IoOFP(io));
- }
- IoIFP(io) = Nullfp;
- IoOFP(io) = Nullfp;
- }
- }
-
- if (i < count) {
- arg = SP[i++];
- }
- }
-
- if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
- filter_sub = arg;
- (void)SvREFCNT_inc(filter_sub);
-
- if (i < count) {
- filter_state = SP[i];
- (void)SvREFCNT_inc(filter_state);
- }
-
- if (tryrsfp == 0) {
- tryrsfp = PerlIO_open("/dev/null",
- PERL_SCRIPT_MODE);
- }
- }
- }
-
- PUTBACK;
- FREETMPS;
- LEAVE;
-
- if (tryrsfp) {
- break;
- }
-
- filter_has_file = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- filter_child_proc = 0;
- }
- if (filter_state) {
- SvREFCNT_dec(filter_state);
- filter_state = 0;
- }
- if (filter_sub) {
- SvREFCNT_dec(filter_sub);
- filter_sub = 0;
- }
- }
- else {
- char *dir = SvPVx(dirsv, n_a);
-#ifdef MACOS_TRADITIONAL
- char buf[256];
- Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
-#else
-#ifdef VMS
- char *unixdir;
- if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
- continue;
- sv_setpv(namesv, unixdir);
- sv_catpv(namesv, unixname);
-#else
- Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
-#endif
-#endif
- TAINT_PROPER("require");
- tryname = SvPVX(namesv);
-#ifdef MACOS_TRADITIONAL
- {
- /* Convert slashes in the name part, but not the directory part, to colons */
- char * colon;
- for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
- *colon++ = ':';
- }
-#endif
- tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
- if (tryrsfp) {
- if (tryname[0] == '.' && tryname[1] == '/')
- tryname += 2;
- break;
- }
- }
- }
- }
- }
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
- SvREFCNT_dec(namesv);
- if (!tryrsfp) {
- if (PL_op->op_type == OP_REQUIRE) {
- char *msgstr = name;
- if (namesv) { /* did we lookup @INC? */
- SV *msg = sv_2mortal(newSVpv(msgstr,0));
- SV *dirmsgsv = NEWSV(0, 0);
- AV *ar = GvAVn(PL_incgv);
- I32 i;
- sv_catpvn(msg, " in @INC", 8);
- if (instr(SvPVX(msg), ".h "))
- sv_catpv(msg, " (change .h to .ph maybe?)");
- if (instr(SvPVX(msg), ".ph "))
- sv_catpv(msg, " (did you run h2ph?)");
- sv_catpv(msg, " (@INC contains:");
- for (i = 0; i <= AvFILL(ar); i++) {
- char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
- Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
- sv_catsv(msg, dirmsgsv);
- }
- sv_catpvn(msg, ")", 1);
- SvREFCNT_dec(dirmsgsv);
- msgstr = SvPV_nolen(msg);
- }
- DIE(aTHX_ "Can't locate %s", msgstr);
- }
-
- RETPUSHUNDEF;
- }
- else
- SETERRNO(0, SS$_NORMAL);
-
- /* Assume success here to prevent recursive requirement. */
- (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
- newSVpv(CopFILE(&PL_compiling), 0), 0 );
-
- ENTER;
- SAVETMPS;
- lex_start(sv_2mortal(newSVpvn("",0)));
- SAVEGENERICSV(PL_rsfp_filters);
- PL_rsfp_filters = Nullav;
-
- PL_rsfp = tryrsfp;
- SAVEHINTS();
- PL_hints = 0;
- SAVESPTR(PL_compiling.cop_warnings);
- if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = pWARN_ALL ;
- else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = pWARN_NONE ;
- else
- PL_compiling.cop_warnings = pWARN_STD ;
-
- if (filter_sub || filter_child_proc) {
- SV *datasv = filter_add(run_user_filter, Nullsv);
- IoLINES(datasv) = filter_has_file;
- IoFMT_GV(datasv) = (GV *)filter_child_proc;
- IoTOP_GV(datasv) = (GV *)filter_state;
- IoBOTTOM_GV(datasv) = (GV *)filter_sub;
- }
-
- /* switch to eval mode */
- push_return(PL_op->op_next);
- PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, name, Nullgv);
-
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 0);
-
- PUTBACK;
-#ifdef USE_THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- if (PL_eval_owner && PL_eval_owner != thr)
- while (PL_eval_owner)
- COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
- PL_eval_owner = thr;
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
- return DOCATCH(doeval(G_SCALAR, NULL));
-}
-
-PP(pp_dofile)
-{
- return pp_require();
-}
-
-PP(pp_entereval)
-{
- dSP;
- register PERL_CONTEXT *cx;
- dPOPss;
- I32 gimme = GIMME_V, was = PL_sub_generation;
- char tbuf[TYPE_DIGITS(long) + 12];
- char *tmpbuf = tbuf;
- char *safestr;
- STRLEN len;
- OP *ret;
-
- if (!SvPV(sv,len) || !len)
- RETPUSHUNDEF;
- TAINT_PROPER("eval");
-
- ENTER;
- lex_start(sv);
- SAVETMPS;
-
- /* switch to eval mode */
-
- if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV *sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
- (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- }
- else
- sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tmpbuf+2);
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepv(tmpbuf);
- SAVEDELETE(PL_defstash, safestr, strlen(safestr));
- SAVEHINTS();
- PL_hints = PL_op->op_targ;
- SAVESPTR(PL_compiling.cop_warnings);
- if (specialWARN(PL_curcop->cop_warnings))
- PL_compiling.cop_warnings = PL_curcop->cop_warnings;
- else {
- PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
- SAVEFREESV(PL_compiling.cop_warnings);
- }
-
- push_return(PL_op->op_next);
- PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
- PUSHEVAL(cx, 0, Nullgv);
-
- /* prepare to compile string */
-
- if (PERLDB_LINE && PL_curstash != PL_debstash)
- save_lines(CopFILEAV(&PL_compiling), PL_linestr);
- PUTBACK;
-#ifdef USE_THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- if (PL_eval_owner && PL_eval_owner != thr)
- while (PL_eval_owner)
- COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
- PL_eval_owner = thr;
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
- ret = doeval(gimme, NULL);
- if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
- && ret != PL_op->op_next) { /* Successive compilation. */
- strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
- }
- return DOCATCH(ret);
-}
-
-PP(pp_leaveeval)
-{
- dSP;
- register SV **mark;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- OP *retop;
- U8 save_flags = PL_op -> op_flags;
- I32 optype;
-
- POPBLOCK(cx,newpm);
- POPEVAL(cx);
- retop = pop_return();
-
- TAINT_NOT;
- if (gimme == G_VOID)
- MARK = newsp;
- else if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & SVs_TEMP)) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
- PL_curpm = newpm; /* Don't pop $1 et al till now */
-
-#ifdef DEBUGGING
- assert(CvDEPTH(PL_compcv) == 1);
-#endif
- CvDEPTH(PL_compcv) = 0;
- lex_end();
-
- if (optype == OP_REQUIRE &&
- !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
- {
- /* Unassume the success we assumed earlier. */
- SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
- /* die_where() did LEAVE, or we won't be here */
- }
- else {
- LEAVE;
- if (!(save_flags & OPf_SPECIAL))
- sv_setpv(ERRSV,"");
- }
-
- RETURNOP(retop);
-}
-
-PP(pp_entertry)
-{
- dSP;
- register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
-
- ENTER;
- SAVETMPS;
-
- push_return(cLOGOP->op_other->op_next);
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
- PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
-
- PL_in_eval = EVAL_INEVAL;
- sv_setpv(ERRSV,"");
- PUTBACK;
- return DOCATCH(PL_op->op_next);
-}
-
-PP(pp_leavetry)
-{
- dSP;
- register SV **mark;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- I32 optype;
-
- POPBLOCK(cx,newpm);
- POPEVAL(cx);
- pop_return();
-
- TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
- PL_curpm = newpm; /* Don't pop $1 et al till now */
-
- LEAVE;
- sv_setpv(ERRSV,"");
- RETURN;
-}
-
-STATIC void
-S_doparseform(pTHX_ SV *sv)
-{
- STRLEN len;
- register char *s = SvPV_force(sv, len);
- register char *send = s + len;
- register char *base;
- register I32 skipspaces = 0;
- bool noblank;
- bool repeat;
- bool postspace = FALSE;
- U16 *fops;
- register U16 *fpc;
- U16 *linepc;
- register I32 arg;
- bool ischop;
-
- if (len == 0)
- Perl_croak(aTHX_ "Null picture in formline");
-
- New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
- fpc = fops;
-
- if (s < send) {
- linepc = fpc;
- *fpc++ = FF_LINEMARK;
- noblank = repeat = FALSE;
- base = s;
- }
-
- while (s <= send) {
- switch (*s++) {
- default:
- skipspaces = 0;
- continue;
-
- case '~':
- if (*s == '~') {
- repeat = TRUE;
- *s = ' ';
- }
- noblank = TRUE;
- s[-1] = ' ';
- /* FALL THROUGH */
- case ' ': case '\t':
- skipspaces++;
- continue;
-
- case '\n': case 0:
- arg = s - base;
- skipspaces++;
- arg -= skipspaces;
- if (arg) {
- if (postspace)
- *fpc++ = FF_SPACE;
- *fpc++ = FF_LITERAL;
- *fpc++ = arg;
- }
- postspace = FALSE;
- if (s <= send)
- skipspaces--;
- if (skipspaces) {
- *fpc++ = FF_SKIP;
- *fpc++ = skipspaces;
- }
- skipspaces = 0;
- if (s <= send)
- *fpc++ = FF_NEWLINE;
- if (noblank) {
- *fpc++ = FF_BLANK;
- if (repeat)
- arg = fpc - linepc + 1;
- else
- arg = 0;
- *fpc++ = arg;
- }
- if (s < send) {
- linepc = fpc;
- *fpc++ = FF_LINEMARK;
- noblank = repeat = FALSE;
- base = s;
- }
- else
- s++;
- continue;
-
- case '@':
- case '^':
- ischop = s[-1] == '^';
-
- if (postspace) {
- *fpc++ = FF_SPACE;
- postspace = FALSE;
- }
- arg = (s - base) - 1;
- if (arg) {
- *fpc++ = FF_LITERAL;
- *fpc++ = arg;
- }
-
- base = s - 1;
- *fpc++ = FF_FETCH;
- if (*s == '*') {
- s++;
- *fpc++ = 0;
- *fpc++ = FF_LINEGLOB;
- }
- else if (*s == '#' || (*s == '.' && s[1] == '#')) {
- arg = ischop ? 512 : 0;
- base = s - 1;
- while (*s == '#')
- s++;
- if (*s == '.') {
- char *f;
- s++;
- f = s;
- while (*s == '#')
- s++;
- arg |= 256 + (s - f);
- }
- *fpc++ = s - base; /* fieldsize for FETCH */
- *fpc++ = FF_DECIMAL;
- *fpc++ = arg;
- }
- else {
- I32 prespace = 0;
- bool ismore = FALSE;
-
- if (*s == '>') {
- while (*++s == '>') ;
- prespace = FF_SPACE;
- }
- else if (*s == '|') {
- while (*++s == '|') ;
- prespace = FF_HALFSPACE;
- postspace = TRUE;
- }
- else {
- if (*s == '<')
- while (*++s == '<') ;
- postspace = TRUE;
- }
- if (*s == '.' && s[1] == '.' && s[2] == '.') {
- s += 3;
- ismore = TRUE;
- }
- *fpc++ = s - base; /* fieldsize for FETCH */
-
- *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
-
- if (prespace)
- *fpc++ = prespace;
- *fpc++ = FF_ITEM;
- if (ismore)
- *fpc++ = FF_MORE;
- if (ischop)
- *fpc++ = FF_CHOP;
- }
- base = s;
- skipspaces = 0;
- continue;
- }
- }
- *fpc++ = FF_END;
-
- arg = fpc - fops;
- { /* need to jump to the next word */
- int z;
- z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
- SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
- s = SvPVX(sv) + SvCUR(sv) + z;
- }
- Copy(fops, s, arg, U16);
- Safefree(fops);
- sv_magic(sv, Nullsv, 'f', Nullch, 0);
- SvCOMPILED_on(sv);
-}
-
-/*
- * The rest of this file was derived from source code contributed
- * by Tom Horsley.
- *
- * NOTE: this code was derived from Tom Horsley's qsort replacement
- * and should not be confused with the original code.
- */
-
-/* Copyright (C) Tom Horsley, 1997. All rights reserved.
-
- Permission granted to distribute under the same terms as perl which are
- (briefly):
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of either:
-
- a) the GNU General Public License as published by the Free
- Software Foundation; either version 1, or (at your option) any
- later version, or
-
- b) the "Artistic License" which comes with this Kit.
-
- Details on the perl license can be found in the perl source code which
- may be located via the www.perl.com web page.
-
- This is the most wonderfulest possible qsort I can come up with (and
- still be mostly portable) My (limited) tests indicate it consistently
- does about 20% fewer calls to compare than does the qsort in the Visual
- C++ library, other vendors may vary.
-
- Some of the ideas in here can be found in "Algorithms" by Sedgewick,
- others I invented myself (or more likely re-invented since they seemed
- pretty obvious once I watched the algorithm operate for a while).
-
- Most of this code was written while watching the Marlins sweep the Giants
- in the 1997 National League Playoffs - no Braves fans allowed to use this
- code (just kidding :-).
-
- I realize that if I wanted to be true to the perl tradition, the only
- comment in this file would be something like:
-
- ...they shuffled back towards the rear of the line. 'No, not at the
- rear!' the slave-driver shouted. 'Three files up. And stay there...
-
- However, I really needed to violate that tradition just so I could keep
- track of what happens myself, not to mention some poor fool trying to
- understand this years from now :-).
-*/
-
-/* ********************************************************** Configuration */
-
-#ifndef QSORT_ORDER_GUESS
-#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
-#endif
-
-/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
- future processing - a good max upper bound is log base 2 of memory size
- (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
- safely be smaller than that since the program is taking up some space and
- most operating systems only let you grab some subset of contiguous
- memory (not to mention that you are normally sorting data larger than
- 1 byte element size :-).
-*/
-#ifndef QSORT_MAX_STACK
-#define QSORT_MAX_STACK 32
-#endif
-
-/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
- Anything bigger and we use qsort. If you make this too small, the qsort
- will probably break (or become less efficient), because it doesn't expect
- the middle element of a partition to be the same as the right or left -
- you have been warned).
-*/
-#ifndef QSORT_BREAK_EVEN
-#define QSORT_BREAK_EVEN 6
-#endif
-
-/* ************************************************************* Data Types */
-
-/* hold left and right index values of a partition waiting to be sorted (the
- partition includes both left and right - right is NOT one past the end or
- anything like that).
-*/
-struct partition_stack_entry {
- int left;
- int right;
-#ifdef QSORT_ORDER_GUESS
- int qsort_break_even;
-#endif
-};
-
-/* ******************************************************* Shorthand Macros */
-
-/* Note that these macros will be used from inside the qsort function where
- we happen to know that the variable 'elt_size' contains the size of an
- array element and the variable 'temp' points to enough space to hold a
- temp element and the variable 'array' points to the array being sorted
- and 'compare' is the pointer to the compare routine.
-
- Also note that there are very many highly architecture specific ways
- these might be sped up, but this is simply the most generally portable
- code I could think of.
-*/
-
-/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
-*/
-#define qsort_cmp(elt1, elt2) \
- ((*compare)(aTHXo_ array[elt1], array[elt2]))
-
-#ifdef QSORT_ORDER_GUESS
-#define QSORT_NOTICE_SWAP swapped++;
-#else
-#define QSORT_NOTICE_SWAP
-#endif
-
-/* swaps contents of array elements elt1, elt2.
-*/
-#define qsort_swap(elt1, elt2) \
- STMT_START { \
- QSORT_NOTICE_SWAP \
- temp = array[elt1]; \
- array[elt1] = array[elt2]; \
- array[elt2] = temp; \
- } STMT_END
-
-/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
- elt3 and elt3 gets elt1.
-*/
-#define qsort_rotate(elt1, elt2, elt3) \
- STMT_START { \
- QSORT_NOTICE_SWAP \
- temp = array[elt1]; \
- array[elt1] = array[elt2]; \
- array[elt2] = array[elt3]; \
- array[elt3] = temp; \
- } STMT_END
-
-/* ************************************************************ Debug stuff */
-
-#ifdef QSORT_DEBUG
-
-static void
-break_here()
-{
- return; /* good place to set a breakpoint */
-}
-
-#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
-
-static void
-doqsort_all_asserts(
- void * array,
- size_t num_elts,
- size_t elt_size,
- int (*compare)(const void * elt1, const void * elt2),
- int pc_left, int pc_right, int u_left, int u_right)
-{
- int i;
-
- qsort_assert(pc_left <= pc_right);
- qsort_assert(u_right < pc_left);
- qsort_assert(pc_right < u_left);
- for (i = u_right + 1; i < pc_left; ++i) {
- qsort_assert(qsort_cmp(i, pc_left) < 0);
- }
- for (i = pc_left; i < pc_right; ++i) {
- qsort_assert(qsort_cmp(i, pc_right) == 0);
- }
- for (i = pc_right + 1; i < u_left; ++i) {
- qsort_assert(qsort_cmp(pc_right, i) < 0);
- }
-}
-
-#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
- doqsort_all_asserts(array, num_elts, elt_size, compare, \
- PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
-
-#else
-
-#define qsort_assert(t) ((void)0)
-
-#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
-
-#endif
-
-/* ****************************************************************** qsort */
-
-STATIC void
-S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
-{
- register SV * temp;
-
- struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
- int next_stack_entry = 0;
-
- int part_left;
- int part_right;
-#ifdef QSORT_ORDER_GUESS
- int qsort_break_even;
- int swapped;
-#endif
-
- /* Make sure we actually have work to do.
- */
- if (num_elts <= 1) {
- return;
- }
-
- /* Setup the initial partition definition and fall into the sorting loop
- */
- part_left = 0;
- part_right = (int)(num_elts - 1);
-#ifdef QSORT_ORDER_GUESS
- qsort_break_even = QSORT_BREAK_EVEN;
-#else
-#define qsort_break_even QSORT_BREAK_EVEN
-#endif
- for ( ; ; ) {
- if ((part_right - part_left) >= qsort_break_even) {
- /* OK, this is gonna get hairy, so lets try to document all the
- concepts and abbreviations and variables and what they keep
- track of:
-
- pc: pivot chunk - the set of array elements we accumulate in the
- middle of the partition, all equal in value to the original
- pivot element selected. The pc is defined by:
-
- pc_left - the leftmost array index of the pc
- pc_right - the rightmost array index of the pc
-
- we start with pc_left == pc_right and only one element
- in the pivot chunk (but it can grow during the scan).
-
- u: uncompared elements - the set of elements in the partition
- we have not yet compared to the pivot value. There are two
- uncompared sets during the scan - one to the left of the pc
- and one to the right.
-
- u_right - the rightmost index of the left side's uncompared set
- u_left - the leftmost index of the right side's uncompared set
-
- The leftmost index of the left sides's uncompared set
- doesn't need its own variable because it is always defined
- by the leftmost edge of the whole partition (part_left). The
- same goes for the rightmost edge of the right partition
- (part_right).
-
- We know there are no uncompared elements on the left once we
- get u_right < part_left and no uncompared elements on the
- right once u_left > part_right. When both these conditions
- are met, we have completed the scan of the partition.
-
- Any elements which are between the pivot chunk and the
- uncompared elements should be less than the pivot value on
- the left side and greater than the pivot value on the right
- side (in fact, the goal of the whole algorithm is to arrange
- for that to be true and make the groups of less-than and
- greater-then elements into new partitions to sort again).
-
- As you marvel at the complexity of the code and wonder why it
- has to be so confusing. Consider some of the things this level
- of confusion brings:
-
- Once I do a compare, I squeeze every ounce of juice out of it. I
- never do compare calls I don't have to do, and I certainly never
- do redundant calls.
-
- I also never swap any elements unless I can prove there is a
- good reason. Many sort algorithms will swap a known value with
- an uncompared value just to get things in the right place (or
- avoid complexity :-), but that uncompared value, once it gets
- compared, may then have to be swapped again. A lot of the
- complexity of this code is due to the fact that it never swaps
- anything except compared values, and it only swaps them when the
- compare shows they are out of position.
- */
- int pc_left, pc_right;
- int u_right, u_left;
-
- int s;
-
- pc_left = ((part_left + part_right) / 2);
- pc_right = pc_left;
- u_right = pc_left - 1;
- u_left = pc_right + 1;
-
- /* Qsort works best when the pivot value is also the median value
- in the partition (unfortunately you can't find the median value
- without first sorting :-), so to give the algorithm a helping
- hand, we pick 3 elements and sort them and use the median value
- of that tiny set as the pivot value.
-
- Some versions of qsort like to use the left middle and right as
- the 3 elements to sort so they can insure the ends of the
- partition will contain values which will stop the scan in the
- compare loop, but when you have to call an arbitrarily complex
- routine to do a compare, its really better to just keep track of
- array index values to know when you hit the edge of the
- partition and avoid the extra compare. An even better reason to
- avoid using a compare call is the fact that you can drop off the
- edge of the array if someone foolishly provides you with an
- unstable compare function that doesn't always provide consistent
- results.
-
- So, since it is simpler for us to compare the three adjacent
- elements in the middle of the partition, those are the ones we
- pick here (conveniently pointed at by u_right, pc_left, and
- u_left). The values of the left, center, and right elements
- are refered to as l c and r in the following comments.
- */
-
-#ifdef QSORT_ORDER_GUESS
- swapped = 0;
-#endif
- s = qsort_cmp(u_right, pc_left);
- if (s < 0) {
- /* l < c */
- s = qsort_cmp(pc_left, u_left);
- /* if l < c, c < r - already in order - nothing to do */
- if (s == 0) {
- /* l < c, c == r - already in order, pc grows */
- ++pc_right;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else if (s > 0) {
- /* l < c, c > r - need to know more */
- s = qsort_cmp(u_right, u_left);
- if (s < 0) {
- /* l < c, c > r, l < r - swap c & r to get ordered */
- qsort_swap(pc_left, u_left);
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else if (s == 0) {
- /* l < c, c > r, l == r - swap c&r, grow pc */
- qsort_swap(pc_left, u_left);
- --pc_left;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else {
- /* l < c, c > r, l > r - make lcr into rlc to get ordered */
- qsort_rotate(pc_left, u_right, u_left);
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- }
- }
- } else if (s == 0) {
- /* l == c */
- s = qsort_cmp(pc_left, u_left);
- if (s < 0) {
- /* l == c, c < r - already in order, grow pc */
- --pc_left;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else if (s == 0) {
- /* l == c, c == r - already in order, grow pc both ways */
- --pc_left;
- ++pc_right;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else {
- /* l == c, c > r - swap l & r, grow pc */
- qsort_swap(u_right, u_left);
- ++pc_right;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- }
- } else {
- /* l > c */
- s = qsort_cmp(pc_left, u_left);
- if (s < 0) {
- /* l > c, c < r - need to know more */
- s = qsort_cmp(u_right, u_left);
- if (s < 0) {
- /* l > c, c < r, l < r - swap l & c to get ordered */
- qsort_swap(u_right, pc_left);
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else if (s == 0) {
- /* l > c, c < r, l == r - swap l & c, grow pc */
- qsort_swap(u_right, pc_left);
- ++pc_right;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else {
- /* l > c, c < r, l > r - rotate lcr into crl to order */
- qsort_rotate(u_right, pc_left, u_left);
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- }
- } else if (s == 0) {
- /* l > c, c == r - swap ends, grow pc */
- qsort_swap(u_right, u_left);
- --pc_left;
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- } else {
- /* l > c, c > r - swap ends to get in order */
- qsort_swap(u_right, u_left);
- qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
- }
- }
- /* We now know the 3 middle elements have been compared and
- arranged in the desired order, so we can shrink the uncompared
- sets on both sides
- */
- --u_right;
- ++u_left;
- qsort_all_asserts(pc_left, pc_right, u_left, u_right);
-
- /* The above massive nested if was the simple part :-). We now have
- the middle 3 elements ordered and we need to scan through the
- uncompared sets on either side, swapping elements that are on
- the wrong side or simply shuffling equal elements around to get
- all equal elements into the pivot chunk.
- */
-
- for ( ; ; ) {
- int still_work_on_left;
- int still_work_on_right;
-
- /* Scan the uncompared values on the left. If I find a value
- equal to the pivot value, move it over so it is adjacent to
- the pivot chunk and expand the pivot chunk. If I find a value
- less than the pivot value, then just leave it - its already
- on the correct side of the partition. If I find a greater
- value, then stop the scan.
- */
- while ((still_work_on_left = (u_right >= part_left))) {
- s = qsort_cmp(u_right, pc_left);
- if (s < 0) {
- --u_right;
- } else if (s == 0) {
- --pc_left;
- if (pc_left != u_right) {
- qsort_swap(u_right, pc_left);
- }
- --u_right;
- } else {
- break;
- }
- qsort_assert(u_right < pc_left);
- qsort_assert(pc_left <= pc_right);
- qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
- qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
- }
-
- /* Do a mirror image scan of uncompared values on the right
- */
- while ((still_work_on_right = (u_left <= part_right))) {
- s = qsort_cmp(pc_right, u_left);
- if (s < 0) {
- ++u_left;
- } else if (s == 0) {
- ++pc_right;
- if (pc_right != u_left) {
- qsort_swap(pc_right, u_left);
- }
- ++u_left;
- } else {
- break;
- }
- qsort_assert(u_left > pc_right);
- qsort_assert(pc_left <= pc_right);
- qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
- qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
- }
-
- if (still_work_on_left) {
- /* I know I have a value on the left side which needs to be
- on the right side, but I need to know more to decide
- exactly the best thing to do with it.
- */
- if (still_work_on_right) {
- /* I know I have values on both side which are out of
- position. This is a big win because I kill two birds
- with one swap (so to speak). I can advance the
- uncompared pointers on both sides after swapping both
- of them into the right place.
- */
- qsort_swap(u_right, u_left);
- --u_right;
- ++u_left;
- qsort_all_asserts(pc_left, pc_right, u_left, u_right);
- } else {
- /* I have an out of position value on the left, but the
- right is fully scanned, so I "slide" the pivot chunk
- and any less-than values left one to make room for the
- greater value over on the right. If the out of position
- value is immediately adjacent to the pivot chunk (there
- are no less-than values), I can do that with a swap,
- otherwise, I have to rotate one of the less than values
- into the former position of the out of position value
- and the right end of the pivot chunk into the left end
- (got all that?).
- */
- --pc_left;
- if (pc_left == u_right) {
- qsort_swap(u_right, pc_right);
- qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
- } else {
- qsort_rotate(u_right, pc_left, pc_right);
- qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
- }
- --pc_right;
- --u_right;
- }
- } else if (still_work_on_right) {
- /* Mirror image of complex case above: I have an out of
- position value on the right, but the left is fully
- scanned, so I need to shuffle things around to make room
- for the right value on the left.
- */
- ++pc_right;
- if (pc_right == u_left) {
- qsort_swap(u_left, pc_left);
- qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
- } else {
- qsort_rotate(pc_right, pc_left, u_left);
- qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
- }
- ++pc_left;
- ++u_left;
- } else {
- /* No more scanning required on either side of partition,
- break out of loop and figure out next set of partitions
- */
- break;
- }
- }
-
- /* The elements in the pivot chunk are now in the right place. They
- will never move or be compared again. All I have to do is decide
- what to do with the stuff to the left and right of the pivot
- chunk.
-
- Notes on the QSORT_ORDER_GUESS ifdef code:
-
- 1. If I just built these partitions without swapping any (or
- very many) elements, there is a chance that the elements are
- already ordered properly (being properly ordered will
- certainly result in no swapping, but the converse can't be
- proved :-).
-
- 2. A (properly written) insertion sort will run faster on
- already ordered data than qsort will.
-
- 3. Perhaps there is some way to make a good guess about
- switching to an insertion sort earlier than partition size 6
- (for instance - we could save the partition size on the stack
- and increase the size each time we find we didn't swap, thus
- switching to insertion sort earlier for partitions with a
- history of not swapping).
-
- 4. Naturally, if I just switch right away, it will make
- artificial benchmarks with pure ascending (or descending)
- data look really good, but is that a good reason in general?
- Hard to say...
- */
-
-#ifdef QSORT_ORDER_GUESS
- if (swapped < 3) {
-#if QSORT_ORDER_GUESS == 1
- qsort_break_even = (part_right - part_left) + 1;
-#endif
-#if QSORT_ORDER_GUESS == 2
- qsort_break_even *= 2;
-#endif
-#if QSORT_ORDER_GUESS == 3
- int prev_break = qsort_break_even;
- qsort_break_even *= qsort_break_even;
- if (qsort_break_even < prev_break) {
- qsort_break_even = (part_right - part_left) + 1;
- }
-#endif
- } else {
- qsort_break_even = QSORT_BREAK_EVEN;
- }
-#endif
-
- if (part_left < pc_left) {
- /* There are elements on the left which need more processing.
- Check the right as well before deciding what to do.
- */
- if (pc_right < part_right) {
- /* We have two partitions to be sorted. Stack the biggest one
- and process the smallest one on the next iteration. This
- minimizes the stack height by insuring that any additional
- stack entries must come from the smallest partition which
- (because it is smallest) will have the fewest
- opportunities to generate additional stack entries.
- */
- if ((part_right - pc_right) > (pc_left - part_left)) {
- /* stack the right partition, process the left */
- partition_stack[next_stack_entry].left = pc_right + 1;
- partition_stack[next_stack_entry].right = part_right;
-#ifdef QSORT_ORDER_GUESS
- partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
-#endif
- part_right = pc_left - 1;
- } else {
- /* stack the left partition, process the right */
- partition_stack[next_stack_entry].left = part_left;
- partition_stack[next_stack_entry].right = pc_left - 1;
-#ifdef QSORT_ORDER_GUESS
- partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
-#endif
- part_left = pc_right + 1;
- }
- qsort_assert(next_stack_entry < QSORT_MAX_STACK);
- ++next_stack_entry;
- } else {
- /* The elements on the left are the only remaining elements
- that need sorting, arrange for them to be processed as the
- next partition.
- */
- part_right = pc_left - 1;
- }
- } else if (pc_right < part_right) {
- /* There is only one chunk on the right to be sorted, make it
- the new partition and loop back around.
- */
- part_left = pc_right + 1;
- } else {
- /* This whole partition wound up in the pivot chunk, so
- we need to get a new partition off the stack.
- */
- if (next_stack_entry == 0) {
- /* the stack is empty - we are done */
- break;
- }
- --next_stack_entry;
- part_left = partition_stack[next_stack_entry].left;
- part_right = partition_stack[next_stack_entry].right;
-#ifdef QSORT_ORDER_GUESS
- qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
-#endif
- }
- } else {
- /* This partition is too small to fool with qsort complexity, just
- do an ordinary insertion sort to minimize overhead.
- */
- int i;
- /* Assume 1st element is in right place already, and start checking
- at 2nd element to see where it should be inserted.
- */
- for (i = part_left + 1; i <= part_right; ++i) {
- int j;
- /* Scan (backwards - just in case 'i' is already in right place)
- through the elements already sorted to see if the ith element
- belongs ahead of one of them.
- */
- for (j = i - 1; j >= part_left; --j) {
- if (qsort_cmp(i, j) >= 0) {
- /* i belongs right after j
- */
- break;
- }
- }
- ++j;
- if (j != i) {
- /* Looks like we really need to move some things
- */
- int k;
- temp = array[i];
- for (k = i - 1; k >= j; --k)
- array[k + 1] = array[k];
- array[j] = temp;
- }
- }
-
- /* That partition is now sorted, grab the next one, or get out
- of the loop if there aren't any more.
- */
-
- if (next_stack_entry == 0) {
- /* the stack is empty - we are done */
- break;
- }
- --next_stack_entry;
- part_left = partition_stack[next_stack_entry].left;
- part_right = partition_stack[next_stack_entry].right;
-#ifdef QSORT_ORDER_GUESS
- qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
-#endif
- }
- }
-
- /* Believe it or not, the array is sorted at this point! */
-}
-
-
-#ifdef PERL_OBJECT
-#undef this
-#define this pPerl
-#include "XSUB.h"
-#endif
-
-
-static I32
-sortcv(pTHXo_ SV *a, SV *b)
-{
- I32 oldsaveix = PL_savestack_ix;
- I32 oldscopeix = PL_scopestack_ix;
- I32 result;
- GvSV(PL_firstgv) = a;
- GvSV(PL_secondgv) = b;
- PL_stack_sp = PL_stack_base;
- PL_op = PL_sortcop;
- CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- if (!SvNIOKp(*PL_stack_sp))
- Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
- result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
- return result;
-}
-
-static I32
-sortcv_stacked(pTHXo_ SV *a, SV *b)
-{
- I32 oldsaveix = PL_savestack_ix;
- I32 oldscopeix = PL_scopestack_ix;
- I32 result;
- AV *av;
-
-#ifdef USE_THREADS
- av = (AV*)PL_curpad[0];
-#else
- av = GvAV(PL_defgv);
-#endif
-
- if (AvMAX(av) < 1) {
- SV** ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
- }
- if (AvMAX(av) < 1) {
- AvMAX(av) = 1;
- Renew(ary,2,SV*);
- SvPVX(av) = (char*)ary;
- }
- }
- AvFILLp(av) = 1;
-
- AvARRAY(av)[0] = a;
- AvARRAY(av)[1] = b;
- PL_stack_sp = PL_stack_base;
- PL_op = PL_sortcop;
- CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- if (!SvNIOKp(*PL_stack_sp))
- Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
- result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
- return result;
-}
-
-static I32
-sortcv_xsub(pTHXo_ SV *a, SV *b)
-{
- dSP;
- I32 oldsaveix = PL_savestack_ix;
- I32 oldscopeix = PL_scopestack_ix;
- I32 result;
- CV *cv=(CV*)PL_sortcop;
-
- SP = PL_stack_base;
- PUSHMARK(SP);
- EXTEND(SP, 2);
- *++SP = a;
- *++SP = b;
- PUTBACK;
- (void)(*CvXSUB(cv))(aTHXo_ cv);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- if (!SvNIOKp(*PL_stack_sp))
- Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
- result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
- return result;
-}
-
-
-static I32
-sv_ncmp(pTHXo_ SV *a, SV *b)
-{
- NV nv1 = SvNV(a);
- NV nv2 = SvNV(b);
- return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
-}
-
-static I32
-sv_i_ncmp(pTHXo_ SV *a, SV *b)
-{
- IV iv1 = SvIV(a);
- IV iv2 = SvIV(b);
- return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
-}
-#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
- *svp = Nullsv; \
- if (PL_amagic_generation) { \
- if (SvAMAGIC(left)||SvAMAGIC(right))\
- *svp = amagic_call(left, \
- right, \
- CAT2(meth,_amg), \
- 0); \
- } \
- } STMT_END
-
-static I32
-amagic_ncmp(pTHXo_ register SV *a, register SV *b)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_ncmp(aTHXo_ a, b);
-}
-
-static I32
-amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_i_ncmp(aTHXo_ a, b);
-}
-
-static I32
-amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_cmp(str1, str2);
-}
-
-static I32
-amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_cmp_locale(str1, str2);
-}
-
-static I32
-run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
-{
- SV *datasv = FILTER_DATA(idx);
- int filter_has_file = IoLINES(datasv);
- GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
- SV *filter_state = (SV *)IoTOP_GV(datasv);
- SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
- int len = 0;
-
- /* I was having segfault trouble under Linux 2.2.5 after a
- parse error occured. (Had to hack around it with a test
- for PL_error_count == 0.) Solaris doesn't segfault --
- not sure where the trouble is yet. XXX */
-
- if (filter_has_file) {
- len = FILTER_READ(idx+1, buf_sv, maxlen);
- }
-
- if (filter_sub && len >= 0) {
- dSP;
- int count;
-
- ENTER;
- SAVE_DEFSV;
- SAVETMPS;
- EXTEND(SP, 2);
-
- DEFSV = buf_sv;
- PUSHMARK(SP);
- PUSHs(sv_2mortal(newSViv(maxlen)));
- if (filter_state) {
- PUSHs(filter_state);
- }
- PUTBACK;
- count = call_sv(filter_sub, G_SCALAR);
- SPAGAIN;
-
- if (count > 0) {
- SV *out = POPs;
- if (SvOK(out)) {
- len = SvIV(out);
- }
- }
-
- PUTBACK;
- FREETMPS;
- LEAVE;
- }
-
- if (len <= 0) {
- IoLINES(datasv) = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- IoFMT_GV(datasv) = Nullgv;
- }
- if (filter_state) {
- SvREFCNT_dec(filter_state);
- IoTOP_GV(datasv) = Nullgv;
- }
- if (filter_sub) {
- SvREFCNT_dec(filter_sub);
- IoBOTTOM_GV(datasv) = Nullgv;
- }
- filter_del(run_user_filter);
- }
-
- return len;
-}
-
-#ifdef PERL_OBJECT
-
-static I32
-sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
-{
- return sv_cmp_locale(str1, str2);
-}
-
-static I32
-sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
-{
- return sv_cmp(str1, str2);
-}
-
-#endif /* PERL_OBJECT */
OpenPOWER on IntegriCloud