#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;

}