#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* Changes in 5.7 series mean that now IOK is only set if scalar is
   precisely integer but in 5.6 and earlier we need to do a more
   complex test  */
#if PERL_VERSION <= 6
#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
#else
#define DD_is_integer(sv) SvIOK(sv)
#endif

static int
is_string0( SV *sv )
{
    return SvFLAGS(sv) & (SVf_OK & ~SVf_ROK);
}

static int
is_string( SV *sv )
{
    STRLEN len = 0;
    if( is_string0(sv) )
    {
        const char *pv = SvPV(sv, len);
    }
    return len;
}

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

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

static int
is_like( 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;
}

MODULE = Params::Util		PACKAGE = Params::Util

void
_STRING(sv)
    SV *sv
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(sv) )
        mg_get(sv);
    if( is_string( sv ) )
    {
        ST(0) = sv;
        XSRETURN(1);
    }
    XSRETURN_UNDEF;
}

void
_NUMBER(sv)
    SV *sv;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(sv) )
        mg_get(sv);
    if( ( SvIOK(sv) ) || ( SvNOK(sv) ) || ( is_string( sv ) && looks_like_number( sv ) ) )
    {
        ST(0) = sv;
        XSRETURN(1);
    }
    XSRETURN_UNDEF;
}

void
_SCALAR0(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        if( ( SvTYPE(SvRV(ref)) <= SVt_PVBM ) && !sv_isobject(ref) )
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }
    XSRETURN_UNDEF;
}

void
_SCALAR(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        svtype tp = SvTYPE(SvRV(ref));
        if( ( SvTYPE(SvRV(ref)) <= SVt_PVBM ) && (!sv_isobject(ref)) && is_string( SvRV(ref) ) )
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }
    XSRETURN_UNDEF;
}

void
_REGEX(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        svtype tp = SvTYPE(SvRV(ref));
#if PERL_VERSION >= 11
        if( ( SVt_REGEXP == tp ) )
#else
        if( ( SVt_PVMG == tp ) && sv_isobject(ref)
         && ( 0 == strncmp( "Regexp", sv_reftype(SvRV(ref),TRUE),
                            strlen("Regexp") ) ) )
#endif
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }
    XSRETURN_UNDEF;
}

void
_ARRAY0(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( is_array(ref) )
    {
        ST(0) = ref;
        XSRETURN(1);
    }

    XSRETURN_UNDEF;
}

void
_ARRAY(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( is_array(ref) && ( av_len((AV *)(SvRV(ref))) >= 0 ) )
    {
        ST(0) = ref;
        XSRETURN(1);
    }
    XSRETURN_UNDEF;
}

void
_ARRAYLIKE(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        if( is_array(ref) || is_like( ref, "@{}" ) )
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }

    XSRETURN_UNDEF;
}

void
_HASH0(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( is_hash(ref) )
    {
        ST(0) = ref;
        XSRETURN(1);
    }

    XSRETURN_UNDEF;
}

void
_HASH(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( is_hash(ref) && ( HvKEYS(SvRV(ref)) >= 1 ) )
    {
        ST(0) = ref;
        XSRETURN(1);
    }

    XSRETURN_UNDEF;
}

void
_HASHLIKE(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        if( is_hash(ref) || is_like( ref, "%{}" ) )
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }

    XSRETURN_UNDEF;
}

void
_CODE(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        if( SVt_PVCV == SvTYPE(SvRV(ref)) )
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }
    XSRETURN_UNDEF;
}

void
_CODELIKE(ref)
    SV *ref;
PROTOTYPE: $
CODE:
{
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) )
    {
        if( ( SVt_PVCV == SvTYPE(SvRV(ref)) ) || ( is_like(ref, "&{}" ) ) )
        {
            ST(0) = ref;
            XSRETURN(1);
        }
    }
    XSRETURN_UNDEF;
}

void
_INSTANCE(ref,type)
    SV *ref;
    char *type;
PROTOTYPE: $$
CODE:
{
    STRLEN len;
    if( SvMAGICAL(ref) )
        mg_get(ref);
    if( SvROK(ref) && type && ( ( len = strlen(type) ) > 0 ) )
    {
        if( sv_isobject(ref) )
        {
            I32 isa_type = 0;
            int count;

            ENTER;
            SAVETMPS;
            PUSHMARK(SP);
            XPUSHs( sv_2mortal( newSVsv( ref ) ) );
            XPUSHs( sv_2mortal( newSVpv( type, len ) ) );
            PUTBACK;

            if( ( count = call_method("isa", G_SCALAR) ) )
            {
                I32 oldax = ax;
                SPAGAIN;
                SP -= count;
                ax = (SP - PL_stack_base) + 1;
                isa_type = SvTRUE(ST(0));
                ax = oldax;
            }

            PUTBACK;
            FREETMPS;
            LEAVE;

            if( isa_type )
            {
                ST(0) = ref;
                XSRETURN(1);
            }
        }
    }
    XSRETURN_UNDEF;
}