#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_sv_2pv_nolen_GLOBAL
#include "ppport.h"
#include "vutil.h"

/* --------------------------------------------------
 * $Revision: 2.5 $
 * --------------------------------------------------*/

typedef     SV *version_vxs;

MODULE = version::vxs PACKAGE = version::vxs

PROTOTYPES: DISABLE
VERSIONCHECK: DISABLE

BOOT:
        /* register the overloading (type 'A') magic */
        PL_amagic_generation++;
        newXS("version::vxs::()", XS_version__vxs_noop, file);
        newXS("version::vxs::(\"\"", XS_version__vxs_stringify, file);
        newXS("version::vxs::(0+", XS_version__vxs_numify, file);
        newXS("version::vxs::(cmp", XS_version__vxs_VCMP, file);
        newXS("version::vxs::(<=>", XS_version__vxs_VCMP, file);
        newXS("version::vxs::(bool", XS_version__vxs_boolean, file);
        newXS("version::vxs::(+", XS_version__vxs_noop, file);
        newXS("version::vxs::(-", XS_version__vxs_noop, file);
        newXS("version::vxs::(*", XS_version__vxs_noop, file);
        newXS("version::vxs::(/", XS_version__vxs_noop, file);
        newXS("version::vxs::(+=", XS_version__vxs_noop, file);
        newXS("version::vxs::(-=", XS_version__vxs_noop, file);
        newXS("version::vxs::(*=", XS_version__vxs_noop, file);
        newXS("version::vxs::(/=", XS_version__vxs_noop, file);
        newXS("version::vxs::(abs", XS_version__vxs_noop, file);
        newXS("version::vxs::nomethod", XS_version__vxs_noop, file);

void
new(...)
ALIAS:
    parse  =  1
PPCODE:
{
    SV *vs = ST(1);
    SV *rv;
    const char * const classname = 
        sv_isobject(ST(0)) /* get the class if called as an object method */
            ? HvNAME_get(SvSTASH(SvRV(ST(0))))
            : (char *)SvPV_nolen(ST(0));
    PERL_UNUSED_ARG(ix);

    if (items > 3)
        Perl_croak(aTHX_ "Usage: version::new(class, version)");

    if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
        /* create empty object */
        vs = sv_newmortal();
        sv_setpvs(vs,"undef");
    }
    else if (items == 3 ) {
        vs = sv_newmortal();
        sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
    }

    rv = NEW_VERSION(vs);
    if ( strcmp(classname,"version::vxs") != 0 ) /* inherited new() */
#if PERL_VERSION == 5
        sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
#else
        sv_bless(rv, gv_stashpv(classname, GV_ADD));
#endif

    mPUSHs(rv);
}

void
stringify (lobj,...)
    version_vxs lobj
PPCODE:
{
    mPUSHs(VSTRINGIFY(lobj));
}

void
numify (lobj,...)
    version_vxs lobj
PPCODE:
{
    mPUSHs(VNUMIFY(lobj));
}

void
normal(ver)
    SV *ver
PPCODE:
{
    mPUSHs(VNORMAL(ver));
}

void
VCMP (lobj,...)
    version_vxs lobj
PPCODE:
{
    SV *rs;
    SV *rvs;
    SV *robj = ST(1);
    const IV  swap = (IV)SvIV(ST(2));

    if ( ! ISA_CLASS_OBJ(robj, "version::vxs") )
    {
        robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("undef", SVs_TEMP));
        sv_2mortal(robj);
    }
    rvs = SvRV(robj);

    if ( swap )
    {
        rs = newSViv(VCMP(rvs,lobj));
    }
    else
    {
        rs = newSViv(VCMP(lobj,rvs));
    }

    mPUSHs(rs);
}

void
boolean(lobj,...)
    version_vxs lobj
PPCODE:
{
    SV * const rs =
    	newSViv( VCMP(lobj,
		      sv_2mortal(NEW_VERSION(
		      		 sv_2mortal(newSVpvs("0"))
				))
		     )
	       );
    mPUSHs(rs);
}

void
noop(lobj,...)
    version_vxs lobj
CODE:
{
    Perl_croak(aTHX_ "operation not supported with version object");
}

void
is_alpha(lobj)
    version_vxs lobj
PPCODE:
{
    if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) )
        XSRETURN_YES;
    else
        XSRETURN_NO;
}

void
qv(...)
ALIAS:
    declare = 1
PPCODE:
{
    SV *ver = ST(0);
    SV * rv;
    const char * classname = "";
    PERL_UNUSED_ARG(ix);
    if ( items == 2 && SvOK(ST(1)) ) {
        /* getting called as object or class method */
        ver = ST(1);
        classname = 
            sv_isobject(ST(0)) /* get the class if called as an object method */
                ? HvNAME_get(SvSTASH(SvRV(ST(0))))
                : (char *)SvPV_nolen(ST(0));
    }
#ifdef SvVOK
    if ( !SvVOK(ver) ) { /* not already a v-string */
#endif
        rv = sv_newmortal();
        sv_setsv(rv,ver); /* make a duplicate */
        UPG_VERSION(rv, TRUE);
#ifdef SvVOK
    }
    else
    {
        rv = sv_2mortal(NEW_VERSION(ver));
    }
#endif
    if ( items == 2 && strcmp(classname,"version") ) {
        /* inherited new() */
#if PERL_VERSION == 5
        sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
#else
        sv_bless(rv, gv_stashpv(classname, GV_ADD));
#endif
    }
    PUSHs(rv);
}

void
is_qv(lobj)
    version_vxs lobj
PPCODE:
{
    if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) )
        XSRETURN_YES;
    else
        XSRETURN_NO;
}

void
_VERSION(sv,...)
    SV *sv
PPCODE:
{
    HV *pkg;
    GV **gvp;
    GV *gv;
    SV *ret;
    const char *undef;

    if (SvROK(sv)) {
        sv = (SV*)SvRV(sv);
        if (!SvOBJECT(sv))
            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
        pkg = SvSTASH(sv);
    }
    else {
        pkg = gv_stashsv(sv, FALSE);
    }

    gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : Null(GV**);

    if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
        sv = sv_mortalcopy(sv);
	if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
	    UPG_VERSION(sv, FALSE);
        undef = NULL;
    }
    else {
        sv = ret = &PL_sv_undef;
        undef = "(undef)";
    }

    if (items > 1) {
        SV *req = ST(1);

        if (undef) {
             if (pkg) {
                const char * const name = HvNAME_get(pkg);
#if PERL_VERSION == 5
                Perl_croak(aTHX_ "%s version %s required--this is only version ",
                            name, SvPVx_nolen_const(req));
#else
                Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
                            name, name);
#endif
             }
             else {
#if PERL_VERSION >= 8
                 Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed",
                            SvPVx_nolen_const(ST(0)) );
#else
                 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
                            SvPVx_nolen_const(ST(0)),
                            SvPVx_nolen_const(ST(0)) );
#endif
             }
        }

        if ( ! ISA_CLASS_OBJ(req, "version")) {
            /* req may very well be R/O, so create a new object */
            req = sv_2mortal( NEW_VERSION(req) );
        }

        if ( VCMP( req, sv ) > 0 ) {
            if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
                req = VNORMAL(req);
                sv  = VNORMAL(sv);
            }
            else {
                req = VSTRINGIFY(req);
                sv  = VSTRINGIFY(sv);
            }
            Perl_croak(aTHX_ "%s version %"SVf" required--"
                "this is only version %"SVf"", HvNAME_get(pkg),
                SVfARG(sv_2mortal(req)),
                SVfARG(sv_2mortal(sv)));
        }
    }
    ST(0) = ret;

    /* if the package's $VERSION is not undef, it is upgraded to be a version object */
    if (ISA_CLASS_OBJ(sv, "version")) {
	ST(0) = sv_2mortal(VSTRINGIFY(sv));
    } else {
	ST(0) = sv;
    }

    XSRETURN(1);
}