File Coverage

XS.xs

Criterion	Covered	Total	%
statement	0	679	0.0
branch	0	780	0.0
condition			n/a
subroutine			n/a
pod			n/a
total	0	1459	0.0

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "multicall.h"
#define NEED_croak_xs_usage
#include "ppport.h"

#ifndef aTHX
#  define aTHX
#  define pTHX
#endif

#ifdef SVf_IVisUV
#  define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
#else
#  define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
#endif

/*
 * Perl < 5.18 had some kind of different SvIV_please_nomg
 */
#if PERL_VERSION < 18
#undef SvIV_please_nomg
#  define SvIV_please_nomg(sv) \
    (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv)) \
        ? (SvIV_nomg(sv), SvIOK(sv))      \
        : SvIOK(sv))
#endif

/* compare left and right SVs. Returns:
 * -1: <
 *  0: ==
 *  1: >
 *  2: left or right was a NaN
 */
static I32
LSUXSncmp(pTHX_ SV* left, SV * right)
{
    /* Fortunately it seems NaN isn't IOK */
    if (SvAMAGIC(left) || SvAMAGIC(right))
        return SvIVX(amagic_call(left, right, ncmp_amg, 0));

    if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
        if (!SvUOK(left)) {
            const IV leftiv = SvIVX(left);
            if (!SvUOK(right)) {
                /* ## IV <=> IV ## */
                const IV rightiv = SvIVX(right);
                return (leftiv > rightiv) - (leftiv < rightiv);
            }
            /* ## IV <=> UV ## */
            if (leftiv < 0)
                /* As (b) is a UV, it's >=0, so it must be < */
                return -1;
            {
                const UV rightuv = SvUVX(right);
                return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
            }
        }

        if (SvUOK(right)) {
            /* ## UV <=> UV ## */
            const UV leftuv = SvUVX(left);
            const UV rightuv = SvUVX(right);
            return (leftuv > rightuv) - (leftuv < rightuv);
        }
        /* ## UV <=> IV ## */
        {
            const IV rightiv = SvIVX(right);
            if (rightiv < 0)
                /* As (a) is a UV, it's >=0, so it cannot be < */
                return 1;
            {
                const UV leftuv = SvUVX(left);
                return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
            }
        }
        assert(0); /* NOTREACHED */
    } else {
#ifdef SvNV_nomg
        NV const rnv = SvNV_nomg(right);
        NV const lnv = SvNV_nomg(left);
#else
        NV const rnv = slu_sv_value(right);
        NV const lnv = slu_sv_value(left);
#endif

#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
        if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
            return 2;
        }
        return (lnv > rnv) - (lnv < rnv);
#else
        if (lnv < rnv)
            return -1;
        if (lnv > rnv)
            return 1;
        if (lnv == rnv)
            return 0;
        return 2;
#endif
    }
}

#define ncmp(left,right) LSUXSncmp(aTHX_ left,right)

#define FUNC_NAME GvNAME(GvEGV(ST(items)))

/* shameless stolen from PadWalker */
#ifndef PadARRAY
typedef AV PADNAMELIST;
typedef SV PADNAME;
# if PERL_VERSION < 8 || (PERL_VERSION == 8 && !PERL_SUBVERSION)
typedef AV PADLIST;
typedef AV PAD;
# endif
# define PadlistARRAY(pl)       ((PAD **)AvARRAY(pl))
# define PadlistMAX(pl)         AvFILLp(pl)
# define PadlistNAMES(pl)       (*PadlistARRAY(pl))
# define PadnamelistARRAY(pnl)  ((PADNAME **)AvARRAY(pnl))
# define PadnamelistMAX(pnl)    AvFILLp(pnl)
# define PadARRAY               AvARRAY
# define PadnameIsOUR(pn)       !!(SvFLAGS(pn) & SVpad_OUR)
# define PadnameOURSTASH(pn)    SvOURSTASH(pn)
# define PadnameOUTER(pn)       !!SvFAKE(pn)
# define PadnamePV(pn)          (SvPOKp(pn) ? SvPVX(pn) : NULL)
#endif
#ifndef PadnameSV
# define PadnameSV(pn)          pn
#endif
#ifndef PadnameFLAGS
# define PadnameFLAGS(pn)       (SvFLAGS(PadnameSV(pn)))
#endif

static int
in_pad (pTHX_ SV *code)
{
    GV *gv;
    HV *stash;
    CV *cv = sv_2cv(code, &stash, &gv, 0);
    PADLIST *pad_list = (CvPADLIST(cv));
    PADNAMELIST *pad_namelist = PadlistNAMES(pad_list);
    int i;

    for (i=PadnamelistMAX(pad_namelist); i>=0; --i) {
        PADNAME* name_pn = PadnamelistARRAY(pad_namelist)[i];
        if (name_pn) {
            char *name_str = PadnamePV(name_pn);
            if (name_str) {

                if (PadnameIsOUR(name_pn))
                    continue;

                if (strEQ(name_str, "$a") || strEQ(name_str, "$b"))
                    return 1;

                if (!((PadnameFLAGS(name_pn)) & SVf_OK))
                    continue;
            }
        }
    }
    return 0;
}

#define WARN_OFF \
    SV *oldwarn = PL_curcop->cop_warnings; \
    PL_curcop->cop_warnings = pWARN_NONE;

#define WARN_ON \
    PL_curcop->cop_warnings = oldwarn;

#define EACH_ARRAY_BODY \
    int i;                                                          \
    arrayeach_args * args;                                          \
    HV *stash = gv_stashpv("List::SomeUtils_ea", TRUE);                 \
    CV *closure = newXS(NULL, XS_List__SomeUtils__XS__array_iterator, __FILE__); \
                                                                        \
    /* prototype */                                         \
    sv_setpv((SV*)closure, ";$");                           \
                                                            \
    New(0, args, 1, arrayeach_args);                        \
    New(0, args->avs, items, AV*);                          \
    args->navs = items;                                     \
    args->curidx = 0;                                       \
                                                            \
    for (i = 0; i < items; i++) {                           \
        if (!arraylike(ST(i)))                                      \
            croak_xs_usage(cv,  "\\@;\\@\\@...");                   \
        args->avs[i] = (AV*)SvRV(ST(i));                            \
        SvREFCNT_inc(args->avs[i]);                                 \
    }                                                               \
                                                                    \
    CvXSUBANY(closure).any_ptr = args;                              \
    RETVAL = newRV_noinc((SV*)closure);                             \
                                                                    \
    /* in order to allow proper cleanup in DESTROY-handler */       \
    sv_bless(RETVAL, stash)

#define FOR_EACH(on_item)           \
    if (!codelike(code))                     \
        croak_xs_usage(cv,  "code, ...");   \
                                            \
    if (items > 1) {                        \
        dMULTICALL;                         \
        int i;                              \
        HV *stash;                          \
        GV *gv;                             \
        CV *_cv;                            \
        SV **args = &PL_stack_base[ax];     \
        I32 gimme = G_SCALAR;               \
        _cv = sv_2cv(code, &stash, &gv, 0); \
        PUSH_MULTICALL(_cv);                \
        SAVESPTR(GvSV(PL_defgv));           \
                                            \
        for (i = 1 ; i < items ; ++i) {     \
            GvSV(PL_defgv) = args[i];       \
            MULTICALL;                      \
            on_item;                        \
        }                                   \
        POP_MULTICALL;                      \
    }

#define TRUE_JUNCTION   \
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) ON_TRUE) \
    else ON_EMPTY;

#define FALSE_JUNCTION  \
    FOR_EACH(if (!SvTRUE(*PL_stack_sp)) ON_FALSE)   \
    else ON_EMPTY;

/* need this one for array_each() */
typedef struct {
    AV **avs;       /* arrays over which to iterate in parallel */
    int navs;       /* number of arrays */
    int curidx;     /* the current index of the iterator */
} arrayeach_args;

/* used for natatime */
typedef struct {
    SV **svs;
    int nsvs;
    int curidx;
    int natatime;
} natatime_args;

static void
insert_after (pTHX_ int idx, SV *what, AV *av) {
    int i, len;
    av_extend(av, (len = av_len(av) + 1));

    for (i = len; i > idx+1; i--) {
        SV **sv = av_fetch(av, i-1, FALSE);
        SvREFCNT_inc(*sv);
        av_store(av, i, *sv);
    }
    if (!av_store(av, idx+1, what))
        SvREFCNT_dec(what);
}

static int
is_like(pTHX_ SV *sv, const char *like)
{
    int likely = 0;
    if ( sv_isobject( sv ) )
        {
            dSP;
        int count;

        ENTER;
        SAVETMPS;
        PUSHMARK(SP);
        XPUSHs( sv_2mortal( newSVsv( sv ) ) );
        XPUSHs( sv_2mortal( newSVpv( like, strlen(like) ) ) );
        PUTBACK;

        if ( ( count = call_pv("overload::Method", G_SCALAR) ) ) {
            I32 ax;
            SPAGAIN;

            SP -= count;
            ax = (SP - PL_stack_base) + 1;
            if ( SvTRUE(ST(0)) )
                ++likely;
        }

        PUTBACK;
        FREETMPS;
        LEAVE;
    }

    return likely;
}

static int
is_array(SV *sv)
{
    return SvROK(sv) && ( SVt_PVAV == SvTYPE(SvRV(sv) ) );
}

static int
LSUXScodelike(pTHX_ SV *code)
{
    SvGETMAGIC(code);
    return SvROK(code) && ( ( SVt_PVCV == SvTYPE(SvRV(code)) ) || ( is_like(aTHX_ code, "&{}" ) ) );
}

#define codelike(code) LSUXScodelike(aTHX_ code)

static int
LSUXSarraylike(pTHX_ SV *array)
{
    SvGETMAGIC(array);
    return is_array(array) || is_like(aTHX_ array, "@{}" );
}

#define arraylike(array) LSUXSarraylike(aTHX_ array)

MODULE = List::SomeUtils_ea             PACKAGE = List::SomeUtils_ea

void
DESTROY(sv)
    SV *sv;
CODE:
{
    int i;
    CV *code = (CV*)SvRV(sv);
    arrayeach_args *args = (arrayeach_args *)(CvXSUBANY(code).any_ptr);
    if (args) {
        for (i = 0; i < args->navs; ++i)
            SvREFCNT_dec(args->avs[i]);
        Safefree(args->avs);
        Safefree(args);
        CvXSUBANY(code).any_ptr = NULL;
    }
}


MODULE = List::SomeUtils_na             PACKAGE = List::SomeUtils_na

void
DESTROY(sv)
    SV *sv;
CODE:
{
    int i;
    CV *code = (CV*)SvRV(sv);
    natatime_args *args = (natatime_args *)(CvXSUBANY(code).any_ptr);
    if (args) {
        for (i = 0; i < args->nsvs; ++i)
            SvREFCNT_dec(args->svs[i]);
        Safefree(args->svs);
        Safefree(args);
        CvXSUBANY(code).any_ptr = NULL;
    }
}

MODULE = List::SomeUtils::XS        PACKAGE = List::SomeUtils::XS

void
any (code,...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_TRUE { POP_MULTICALL; XSRETURN_YES; }
#define ON_EMPTY XSRETURN_NO
    TRUE_JUNCTION;
    XSRETURN_NO;
#undef ON_EMPTY
#undef ON_TRUE
}

void
all (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_FALSE { POP_MULTICALL; XSRETURN_NO; }
#define ON_EMPTY XSRETURN_YES
    FALSE_JUNCTION;
    XSRETURN_YES;
#undef ON_EMPTY
#undef ON_FALSE
}


void
none (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_TRUE { POP_MULTICALL; XSRETURN_NO; }
#define ON_EMPTY XSRETURN_YES
    TRUE_JUNCTION;
    XSRETURN_YES;
#undef ON_EMPTY
#undef ON_TRUE
}

void
notall (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_FALSE { POP_MULTICALL; XSRETURN_YES; }
#define ON_EMPTY XSRETURN_NO
    FALSE_JUNCTION;
    XSRETURN_NO;
#undef ON_EMPTY
#undef ON_FALSE
}

void
one (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    int found = 0;
#define ON_TRUE { if (found++) { POP_MULTICALL; XSRETURN_NO; }; }
#define ON_EMPTY XSRETURN_NO
    TRUE_JUNCTION;
    if (found)
        XSRETURN_YES;
    XSRETURN_NO;
#undef ON_EMPTY
#undef ON_TRUE
}

void
any_u (code,...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_TRUE { POP_MULTICALL; XSRETURN_YES; }
#define ON_EMPTY XSRETURN_UNDEF
    TRUE_JUNCTION;
    XSRETURN_NO;
#undef ON_EMPTY
#undef ON_TRUE
}

void
all_u (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_FALSE { POP_MULTICALL; XSRETURN_NO; }
#define ON_EMPTY XSRETURN_UNDEF
    FALSE_JUNCTION;
    XSRETURN_YES;
#undef ON_EMPTY
#undef ON_FALSE
}


void
none_u (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_TRUE { POP_MULTICALL; XSRETURN_NO; }
#define ON_EMPTY XSRETURN_UNDEF
    TRUE_JUNCTION;
    XSRETURN_YES;
#undef ON_EMPTY
#undef ON_TRUE
}

void
notall_u (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
#define ON_FALSE { POP_MULTICALL; XSRETURN_YES; }
#define ON_EMPTY XSRETURN_UNDEF
    FALSE_JUNCTION;
    XSRETURN_NO;
#undef ON_EMPTY
#undef ON_FALSE
}

void
one_u (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    int found = 0;
#define ON_TRUE { if (found++) { POP_MULTICALL; XSRETURN_NO; }; }
#define ON_EMPTY XSRETURN_UNDEF
    TRUE_JUNCTION;
    if (found)
        XSRETURN_YES;
    XSRETURN_NO;
#undef ON_EMPTY
#undef ON_TRUE
}

int
true (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    I32 count = 0;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) count++);
    RETVAL = count;
}
OUTPUT:
    RETVAL

int
false (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    I32 count = 0;
    FOR_EACH(if (!SvTRUE(*PL_stack_sp)) count++);
    RETVAL = count;
}
OUTPUT:
    RETVAL

int
firstidx (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    RETVAL = -1;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) { RETVAL = i-1; break; });
}
OUTPUT:
    RETVAL

SV *
firstval (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    RETVAL = &PL_sv_undef;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) { SvREFCNT_inc(RETVAL = args[i]); break; });
}
OUTPUT:
    RETVAL

SV *
firstres (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    RETVAL = &PL_sv_undef;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) { SvREFCNT_inc(RETVAL = *PL_stack_sp); break; });
}
OUTPUT:
    RETVAL

int
onlyidx (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    int found = 0;
    RETVAL = -1;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) { if (found++) {RETVAL = -1; break;} RETVAL = i-1; });
}
OUTPUT:
    RETVAL

SV *
onlyval (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    int found = 0;
    RETVAL = &PL_sv_undef;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) { if (found++) {SvREFCNT_dec(RETVAL); RETVAL = &PL_sv_undef; break;} SvREFCNT_inc(RETVAL = args[i]); });
}
OUTPUT:
    RETVAL

SV *
onlyres (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    int found = 0;
    RETVAL = &PL_sv_undef;
    FOR_EACH(if (SvTRUE(*PL_stack_sp)) { if (found++) {SvREFCNT_dec(RETVAL); RETVAL = &PL_sv_undef; break;}SvREFCNT_inc(RETVAL = *PL_stack_sp); });
}
OUTPUT:
    RETVAL

int
lastidx (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    RETVAL = -1;

    if (items > 1) {
        _cv = sv_2cv(code, &stash, &gv, 0);
        PUSH_MULTICALL(_cv);
        SAVESPTR(GvSV(PL_defgv));

        for (i = items-1 ; i > 0 ; --i) {
            GvSV(PL_defgv) = args[i];
            MULTICALL;
            if (SvTRUE(*PL_stack_sp)) {
                RETVAL = i-1;
                break;
            }
        }
        POP_MULTICALL;
    }
}
OUTPUT:
    RETVAL

SV *
lastval (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    RETVAL = &PL_sv_undef;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items > 1) {
        _cv = sv_2cv(code, &stash, &gv, 0);
        PUSH_MULTICALL(_cv);
        SAVESPTR(GvSV(PL_defgv));

        for (i = items-1 ; i > 0 ; --i) {
            GvSV(PL_defgv) = args[i];
            MULTICALL;
            if (SvTRUE(*PL_stack_sp)) {
                /* see comment in indexes() */
                SvREFCNT_inc(RETVAL = args[i]);
                break;
            }
        }
        POP_MULTICALL;
    }
}
OUTPUT:
    RETVAL

SV *
lastres (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    RETVAL = &PL_sv_undef;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items > 1) {
        _cv = sv_2cv(code, &stash, &gv, 0);
        PUSH_MULTICALL(_cv);
        SAVESPTR(GvSV(PL_defgv));

        for (i = items-1 ; i > 0 ; --i) {
            GvSV(PL_defgv) = args[i];
            MULTICALL;
            if (SvTRUE(*PL_stack_sp)) {
                /* see comment in indexes() */
                SvREFCNT_inc(RETVAL = *PL_stack_sp);
                break;
            }
        }
        POP_MULTICALL;
    }
}
OUTPUT:
    RETVAL

int
insert_after (code, val, avref)
    SV *code;
    SV *val;
    SV *avref;
PROTOTYPE: &$\@
CODE:
{
    dMULTICALL;
    int i;
    int len;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    CV *_cv;
    AV *av;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, val, \\@area_of_operation");
    if (!arraylike(avref))
        croak_xs_usage(cv,  "code, val, \\@area_of_operation");

    av = (AV*)SvRV(avref);
    len = av_len(av);
    RETVAL = 0;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 0; i <= len ; ++i) {
        GvSV(PL_defgv) = *av_fetch(av, i, FALSE);
        MULTICALL;
        if (SvTRUE(*PL_stack_sp)) {
            RETVAL = 1;
            break;
        }
    }

    POP_MULTICALL;

    if (RETVAL) {
        SvREFCNT_inc(val);
        insert_after(aTHX_ i, val, av);
    }
}
OUTPUT:
    RETVAL

int
insert_after_string (string, val, avref)
    SV *string;
    SV *val;
    SV *avref;
PROTOTYPE: $$\@
CODE:
{
    int i;
    AV *av;
    int len;
    SV **sv;
    STRLEN slen = 0, alen;
    char *str;
    char *astr;
    RETVAL = 0;

    if (!arraylike(avref))
        croak_xs_usage(cv,  "string, val, \\@area_of_operation");

    av = (AV*)SvRV(avref);
    len = av_len(av);

    if (SvTRUE(string))
        str = SvPV(string, slen);
    else
        str = NULL;

    for (i = 0; i <= len ; i++) {
        sv = av_fetch(av, i, FALSE);
        if (SvTRUE(*sv))
            astr = SvPV(*sv, alen);
        else {
            astr = NULL;
            alen = 0;
        }
        if (slen == alen && memcmp(astr, str, slen) == 0) {
            RETVAL = 1;
            break;
        }
    }
    if (RETVAL) {
        SvREFCNT_inc(val);
        insert_after(aTHX_ i, val, av);
    }
}
OUTPUT:
    RETVAL

void
apply (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    CV *_cv;
    SV **args = &PL_stack_base[ax];

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items <= 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1 ; i < items ; ++i) {
        GvSV(PL_defgv) = newSVsv(args[i]);
        MULTICALL;
        args[i-1] = GvSV(PL_defgv);
    }
    POP_MULTICALL;

    for (i = 1 ; i < items ; ++i)
        sv_2mortal(args[i-1]);

    XSRETURN(items-1);
}

void
after (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i, j;
    HV *stash;
    CV *_cv;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items <= 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1; i < items; i++) {
        GvSV(PL_defgv) = args[i];
        MULTICALL;
        if (SvTRUE(*PL_stack_sp)) {
            break;
        }
    }

    POP_MULTICALL;

    for (j = i + 1; j < items; ++j)
        args[j-i-1] = args[j];

    j = items-i-1;
    XSRETURN(j > 0 ? j : 0);
}

void
after_incl (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i, j;
    HV *stash;
    CV *_cv;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items <= 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1; i < items; i++) {
        GvSV(PL_defgv) = args[i];
        MULTICALL;
        if (SvTRUE(*PL_stack_sp)) {
            break;
        }
    }

    POP_MULTICALL;

    for (j = i; j < items; j++)
        args[j-i] = args[j];

    XSRETURN(items-i);
}

void
before (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items <= 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1; i < items; i++) {
        GvSV(PL_defgv) = args[i];
        MULTICALL;
        if (SvTRUE(*PL_stack_sp)) {
            break;
        }
        args[i-1] = args[i];
    }

    POP_MULTICALL;

    XSRETURN(i-1);
}

void
before_incl (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items <= 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1; i < items; ++i) {
        GvSV(PL_defgv) = args[i];
        MULTICALL;
        args[i-1] = args[i];
        if (SvTRUE(*PL_stack_sp)) {
            ++i;
            break;
        }
    }

    POP_MULTICALL;

    XSRETURN(i-1);
}

void
indexes (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i, j;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items <= 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1, j = 0; i < items; i++) {
        GvSV(PL_defgv) = args[i];
        MULTICALL;
        if (SvTRUE(*PL_stack_sp))
            /* POP_MULTICALL can free mortal temporaries, so we defer
             * mortalising the returned values till after that's been done */
            args[j++] = newSViv(i-1);
    }

    POP_MULTICALL;

    for (i = 0; i < j; i++)
        sv_2mortal(args[i]);

    XSRETURN(j);
}

void
_array_iterator (method = "")
    const char *method;
PROTOTYPE: ;$
CODE:
{
    int i;
    int exhausted = 1;

    /* 'cv' is the hidden argument with which
     * XS_List__SomeUtils__XS__array_iterator (this XSUB) is called. The
     * closure_arg struct is stored in this CV. */

    arrayeach_args *args = (arrayeach_args *)(CvXSUBANY(cv).any_ptr);

    if (strEQ(method, "index")) {
        EXTEND(SP, 1);
        ST(0) = args->curidx > 0 ? sv_2mortal(newSViv(args->curidx-1)) : &PL_sv_undef;
        XSRETURN(1);
    }

    EXTEND(SP, args->navs);

    for (i = 0; i < args->navs; i++) {
        AV *av = args->avs[i];
        if (args->curidx <= av_len(av)) {
            ST(i) = sv_2mortal(newSVsv(*av_fetch(av, args->curidx, FALSE)));
            exhausted = 0;
            continue;
        }
        ST(i) = &PL_sv_undef;
    }

    if (exhausted)
        XSRETURN_EMPTY;

    args->curidx++;
    XSRETURN(args->navs);
}

SV *
each_array (...)
PROTOTYPE: \@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@
CODE:
{
    EACH_ARRAY_BODY;
}
OUTPUT:
    RETVAL

SV *
each_arrayref (...)
CODE:
{
    EACH_ARRAY_BODY;
}
OUTPUT:
    RETVAL

void
pairwise (code, ...)
    SV *code;
PROTOTYPE: &\@\@
PPCODE:
{
#define av_items(a) (av_len(a)+1)

    /* This function is not quite as efficient as it ought to be: We call
     * 'code' multiple times and want to gather its return values all in one
     * list. However, each call resets the stack pointer so there is no
     * obvious way to get the return values onto the stack without making
     * intermediate copies of the pointers.  The above disabled solution would
     * be more efficient. Unfortunately it doesn't work (and, as of now,
     * wouldn't deal with 'code' returning more than one value).
     *
     * The current solution is a fair trade-off. It only allocates memory for
     * a list of SV-pointers, as many as there are return values. It
     * temporarily stores 'code's return values in this list and, when done,
     * copies them down to SP. */

    int i, j;
    AV *avs[2];
    SV **buf, **p;  /* gather return values here and later copy down to SP */
    int alloc;

    int nitems = 0, maxitems = 0;
    int d;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, list, list");
    if (!arraylike(ST(1)))
        croak_xs_usage(cv,  "code, list, list");
    if (!arraylike(ST(2)))
        croak_xs_usage(cv,  "code, list, list");

    if (in_pad(aTHX_ code)) {
        croak("Can't use lexical $a or $b in pairwise code block");
    }

    /* deref AV's for convenience and
     * get maximum items */
    avs[0] = (AV*)SvRV(ST(1));
    avs[1] = (AV*)SvRV(ST(2));
    maxitems = av_items(avs[0]);
    if (av_items(avs[1]) > maxitems)
        maxitems = av_items(avs[1]);

    if (!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);
    }

    New(0, buf, alloc = maxitems, SV*);

    ENTER;
    for (d = 0, i = 0; i < maxitems; i++) {
        int nret;
        SV **svp = av_fetch(avs[0], i, FALSE);
        GvSV(PL_firstgv) = svp ? *svp : &PL_sv_undef;
        svp = av_fetch(avs[1], i, FALSE);
        GvSV(PL_secondgv) = svp ? *svp : &PL_sv_undef;
        PUSHMARK(SP);
        PUTBACK;
        nret = call_sv(code, G_EVAL|G_ARRAY);
        if (SvTRUE(ERRSV)) {
            Safefree(buf);
            croak("%s", SvPV_nolen(ERRSV));
        }
        SPAGAIN;
        nitems += nret;
        if (nitems > alloc) {
	  while (nitems > alloc) {
            alloc <<= 2;
	  }
          Renew(buf, alloc, SV*);
        }
        for (j = nret-1; j >= 0; j--) {
            /* POPs would return elements in reverse order */
            buf[d] = sp[-j];
            d++;
        }
        sp -= nret;
    }
    LEAVE;
    EXTEND(SP, nitems);
    p = buf;
    for (i = 0; i < nitems; i++)
        ST(i) = *p++;

    Safefree(buf);
    XSRETURN(nitems);
}

void
_natatime_iterator ()
PROTOTYPE:
CODE:
{
    int i;
    int nret;

    /* 'cv' is the hidden argument with which
     * XS_List__SomeUtils__XS__array_iterator (this XSUB) is called. The
     * closure_arg struct is stored in this CV. */

    natatime_args *args = (natatime_args*)CvXSUBANY(cv).any_ptr;

    nret = args->natatime;

    EXTEND(SP, nret);

    for (i = 0; i < args->natatime; i++) {
        if (args->curidx < args->nsvs) {
            ST(i) = sv_2mortal(newSVsv(args->svs[args->curidx++]));
        }
        else {
            XSRETURN(i);
        }
    }

    XSRETURN(nret);
}

SV *
natatime (n, ...)
    int n;
PROTOTYPE: $@
CODE:
{
    int i;
    natatime_args * args;
    HV *stash = gv_stashpv("List::SomeUtils_na", TRUE);

    CV *closure = newXS(NULL, XS_List__SomeUtils__XS__natatime_iterator, __FILE__);

    /* must NOT set prototype on iterator: otherwise one cannot write: &$it */
    /* !! sv_setpv((SV*)closure, ""); !! */

    New(0, args, 1, natatime_args);
    New(0, args->svs, items-1, SV*);
    args->nsvs = items-1;
    args->curidx = 0;
    args->natatime = n;

    for (i = 1; i < items; i++)
        SvREFCNT_inc(args->svs[i-1] = ST(i));

    CvXSUBANY(closure).any_ptr = args;
    RETVAL = newRV_noinc((SV*)closure);

    /* in order to allow proper cleanup in DESTROY-handler */
    sv_bless(RETVAL, stash);
}
OUTPUT:
    RETVAL

void
mesh (...)
PROTOTYPE: \@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@
CODE:
{
    int i, j, maxidx = -1;
    AV **avs;
    New(0, avs, items, AV*);

    for (i = 0; i < items; i++) {
        if (!arraylike(ST(i)))
            croak_xs_usage(cv,  "\\@;\\@\\@...");
        avs[i] = (AV*)SvRV(ST(i));
        if (av_len(avs[i]) > maxidx)
            maxidx = av_len(avs[i]);
    }

    EXTEND(SP, items * (maxidx + 1));
    for (i = 0; i <= maxidx; i++) {
        for (j = 0; j < items; j++) {
            SV **svp = av_fetch(avs[j], i, FALSE);
            ST(i*items + j) = svp ? sv_2mortal(newSVsv(*svp)) : &PL_sv_undef;
        }
    }

    Safefree(avs);
    XSRETURN(items * (maxidx + 1));
}

void
uniq (...)
PROTOTYPE: @
CODE:
{
    I32 i;
    IV count = 0, seen_undef = 0;
    HV *hv = newHV();
    SV **args = &PL_stack_base[ax];
    SV *tmp = sv_newmortal();
    sv_2mortal(newRV_noinc((SV*)hv));

    /* don't build return list in scalar context */
    if (GIMME_V == G_SCALAR) {
        for (i = 0; i < items; i++) {
            SvGETMAGIC(args[i]);
            if (SvOK(args[i])) {
                sv_setsv_nomg(tmp, args[i]);
                if (!hv_exists_ent(hv, tmp, 0)) {
                    ++count;
                    hv_store_ent(hv, tmp, &PL_sv_yes, 0);
                }
            }
            else if (0 == seen_undef++) {
                ++count;
            }
        }
        ST(0) = sv_2mortal(newSVuv(count));
        XSRETURN(1);
    }

    /* list context: populate SP with mortal copies */
    for (i = 0; i < items; i++) {
        SvGETMAGIC(args[i]);
        if (SvOK(args[i])) {
            SvSetSV_nosteal(tmp, args[i]);
            if (!hv_exists_ent(hv, tmp, 0)) {
                /*ST(count) = sv_2mortal(newSVsv(ST(i)));
                  ++count;*/
                args[count++] = args[i];
                hv_store_ent(hv, tmp, &PL_sv_yes, 0);
            }
        }
        else if (0 == seen_undef++) {
            args[count++] = args[i];
        }
    }

    XSRETURN(count);
}

void
singleton (...)
PROTOTYPE: @
CODE:
{
    I32 i;
    IV cnt = 0, count = 0, seen_undef = 0;
    HV *hv = newHV();
    SV **args = &PL_stack_base[ax];
    SV *tmp = sv_newmortal();

    sv_2mortal(newRV_noinc((SV*)hv));

    for (i = 0; i < items; i++) {
        SvGETMAGIC(args[i]);
        if (SvOK(args[i])) {
            HE *he;
            SvSetSV_nosteal(tmp, args[i]);
            he = hv_fetch_ent(hv, tmp, 0, 0);
            if (NULL == he) {
                /* ST(count) = sv_2mortal(newSVsv(ST(i))); */
                args[count++] = args[i];
                hv_store_ent(hv, tmp, newSViv(1), 0);
            }
            else {
                SV *v = HeVAL(he);
                IV how_many = SvIVX(v);
                sv_setiv(v, ++how_many);
            }
        }
        else if (0 == seen_undef++) {
            args[count++] = args[i];
        }
    }

    /* don't build return list in scalar context */
    if (GIMME_V == G_SCALAR) {
        for (i = 0; i < count; i++) {
            if (SvOK(args[i])) {
                HE *he;
                sv_setsv_nomg(tmp, args[i]);
                he = hv_fetch_ent(hv, tmp, 0, 0);
                if (he) {
                    SV *v = HeVAL(he);
                    IV how_many = SvIVX(v);
                    if ( 1 == how_many )
                        ++cnt;
                }
            }
            else if (1 == seen_undef) {
                ++cnt;
            }
        }
        ST(0) = sv_2mortal(newSViv(cnt));
        XSRETURN(1);
    }

    /* list context: populate SP with mortal copies */
    for (i = 0; i < count; i++) {
        if (SvOK(args[i])) {
            HE *he;
            SvSetSV_nosteal(tmp, args[i]);
            he = hv_fetch_ent(hv, tmp, 0, 0);
            if (he) {
                SV *v = HeVAL(he);
                IV how_many = SvIVX(v);
                if ( 1 == how_many )
                    args[cnt++] = args[i];
            }
        }
        else if (1 == seen_undef) {
            args[cnt++] = args[i];
        }
    }

    XSRETURN(cnt);
}

void
minmax (...)
PROTOTYPE: @
CODE:
{
    I32 i;
    SV *minsv, *maxsv;

    if (!items)
        XSRETURN_EMPTY;

    if (items == 1) {
        EXTEND(SP, 1);
        ST(1) = sv_2mortal(newSVsv(ST(0)));
        XSRETURN(2);
    }

    minsv = maxsv = ST(0);

    for (i = 1; i < items; i += 2) {
        SV *asv = ST(i-1);
        SV *bsv = ST(i);
        int cmp = ncmp(asv, bsv);
        if (cmp < 0) {
            int min_cmp = ncmp(minsv, asv);
            int max_cmp = ncmp(maxsv, bsv);
            if (min_cmp > 0) {
                minsv = asv;
            }
            if (max_cmp < 0) {
                maxsv = bsv;
            }
        } else {
            int min_cmp = ncmp(minsv, bsv);
            int max_cmp = ncmp(maxsv, asv);
            if (min_cmp > 0) {
                minsv = bsv;
            }
            if (max_cmp < 0) {
                maxsv = asv;
            }
        }
    }

    if (items & 1) {
        SV *rsv = ST(items-1);
        if (ncmp(minsv, rsv) > 0) {
            minsv = rsv;
        }
        else if (ncmp(maxsv, rsv) < 0) {
            maxsv = rsv;
        }
    }

    ST(0) = minsv;
    ST(1) = maxsv;

    XSRETURN(2);
}

void
part (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    int i;
    HV *stash;
    GV *gv;
    I32 gimme = G_SCALAR;
    SV **args = &PL_stack_base[ax];
    CV *_cv;

    AV **tmp = NULL;
    int last = 0;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items == 1)
        XSRETURN_EMPTY;

    _cv = sv_2cv(code, &stash, &gv, 0);
    PUSH_MULTICALL(_cv);
    SAVESPTR(GvSV(PL_defgv));

    for (i = 1 ; i < items ; ++i) {
        int idx;
        GvSV(PL_defgv) = args[i];
        MULTICALL;
        idx = SvIV(*PL_stack_sp);

        if (idx < 0 && (idx += last) < 0)
            croak("Modification of non-creatable array value attempted, subscript %i", idx);

        if (idx >= last) {
            int oldlast = last;
            last = idx + 1;
            Renew(tmp, last, AV*);
            Zero(tmp + oldlast, last - oldlast, AV*);
        }
        if (!tmp[idx])
            tmp[idx] = newAV();
        av_push(tmp[idx], newSVsv( args[i] ));
    }
    POP_MULTICALL;

    EXTEND(SP, last);
    for (i = 0; i < last; ++i) {
        if (tmp[i])
            ST(i) = sv_2mortal(newRV_noinc((SV*)tmp[i]));
        else
            ST(i) = &PL_sv_undef;
    }

    Safefree(tmp);
    XSRETURN(last);
}

SV *
bsearch (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    HV *stash;
    GV *gv;
    I32 gimme = GIMME_V; /* perl-5.5.4 bus-errors out later when using GIMME
                            therefore we save its value in a fresh variable */
    SV **args = &PL_stack_base[ax];

    long i, j;
    int val = -1;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    if (items > 1) {
        CV *_cv = sv_2cv(code, &stash, &gv, 0);
        PUSH_MULTICALL(_cv);
        SAVESPTR(GvSV(PL_defgv));

        i = 0;
        j = items - 1;
        do {
            long k = (i + j) / 2;

            if (k >= items-1)
                break;

            GvSV(PL_defgv) = args[1+k];
            MULTICALL;
            val = SvIV(*PL_stack_sp);

            if (val == 0) {
                POP_MULTICALL;
                if (gimme != G_ARRAY) {
                    XSRETURN_YES;
                }
                SvREFCNT_inc(RETVAL = args[1+k]);
                goto yes;
            }
            if (val < 0) {
                i = k+1;
            } else {
                j = k-1;
            }
        } while (i <= j);
        POP_MULTICALL;
    }

    if (gimme == G_ARRAY)
        XSRETURN_EMPTY;
    else
        XSRETURN_UNDEF;
 yes:
    ;
}
OUTPUT:
    RETVAL

int
bsearchidx (code, ...)
    SV *code;
PROTOTYPE: &@
CODE:
{
    dMULTICALL;
    HV *stash;
    GV *gv;
    I32 gimme = GIMME_V; /* perl-5.5.4 bus-errors out later when using GIMME
                            therefore we save its value in a fresh variable */
    SV **args = &PL_stack_base[ax];

    long i, j;
    int val = -1;

    if (!codelike(code))
        croak_xs_usage(cv,  "code, ...");

    RETVAL = -1;

    if (items > 1) {
        CV *_cv = sv_2cv(code, &stash, &gv, 0);
        PUSH_MULTICALL(_cv);
        SAVESPTR(GvSV(PL_defgv));

        i = 0;
        j = items - 1;
        do {
            long k = (i + j) / 2;

            if (k >= items-1)
                break;

            GvSV(PL_defgv) = args[1+k];
            MULTICALL;
            val = SvIV(*PL_stack_sp);

            if (val == 0) {
                RETVAL = k;
                break;
            }
            if (val < 0) {
                i = k+1;
            } else {
                j = k-1;
            }
        } while (i <= j);
        POP_MULTICALL;
    }
}
OUTPUT:
    RETVAL

void
mode (...)
PROTOTYPE: @
PPCODE:
{
    int i;
    unsigned int max = 0;
    unsigned int c = 0;
    unsigned int modality = 0;
    SV **args = &PL_stack_base[ax];
    HV *hv = newHV();
    SV *tmp = sv_newmortal();
    HE *he;

    sv_2mortal(newRV_noinc((SV*)hv));
    if (!items) {
        if (GIMME_V == G_SCALAR) {
            mPUSHi(0);
            PUTBACK;
            return;
        }
        else {
            XSRETURN_EMPTY;
        }
    }

    for (i = 0; i < items; i++) {
        SvGETMAGIC(args[i]);

        SvSetSV_nosteal(tmp, args[i]);
        he = hv_fetch_ent(hv, tmp, 0, 0);

        if (NULL == he) {
            hv_store_ent(hv, tmp, newSViv(1), 0);
        }
        else {
            SV *v = HeVAL(he);
            IV how_many = SvIVX(v);
            sv_setiv(v, ++how_many);
        }
    }

    hv_iterinit(hv);
    while ((he = hv_iternext(hv))) {
        c = SvIV(HeVAL(he));
        if (c > max) {
            max = c;
        }
    }

    i = 0;
    hv_iterinit(hv);
    while ((he = hv_iternext(hv))) {
        if (SvIV(HeVAL(he)) == max) {
            if (GIMME_V == G_SCALAR) {
                modality++;
            } else {
                XPUSHs(HeSVKEY_force(he));
            }
        }
    }

    if  (GIMME_V == G_SCALAR) {
        mXPUSHu(modality);
    }
}