-XS(XS_UNIVERSAL_VERSION)
-{
- dVAR;
- dXSARGS;
- HV *pkg;
- GV **gvp;
- GV *gv;
- SV *sv;
- const char *undef;
- PERL_UNUSED_ARG(cv);
-
- if (SvROK(ST(0))) {
- sv = MUTABLE_SV(SvRV(ST(0)));
- if (!SvOBJECT(sv))
- Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
- pkg = SvSTASH(sv);
- }
- else {
- pkg = gv_stashsv(ST(0), 0);
- }
-
- gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
-
- if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
- SV * const nsv = sv_newmortal();
- sv_setsv(nsv, sv);
- sv = nsv;
- if ( !sv_derived_from(sv, "version"))
- upg_version(sv, FALSE);
- undef = NULL;
- }
- else {
- sv = &PL_sv_undef;
- undef = "(undef)";
- }
-
- if (items > 1) {
- SV *req = ST(1);
-
- if (undef) {
- if (pkg) {
- const char * const name = HvNAME_get(pkg);
- Perl_croak(aTHX_
- "%s does not define $%s::VERSION--version check failed",
- name, name);
- } else {
- Perl_croak(aTHX_
- "%s defines neither package nor VERSION--version check failed",
- SvPVx_nolen_const(ST(0)) );
- }
- }
-
- if ( !sv_derived_from(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 ) ) {
- Perl_croak(aTHX_ "%s version %"SVf" required--"
- "this is only version %"SVf"", HvNAME_get(pkg),
- SVfARG(sv_2mortal(vnormal(req))),
- SVfARG(sv_2mortal(vnormal(sv))));
- } else {
- Perl_croak(aTHX_ "%s version %"SVf" required--"
- "this is only version %"SVf"", HvNAME_get(pkg),
- SVfARG(sv_2mortal(vstringify(req))),
- SVfARG(sv_2mortal(vstringify(sv))));
- }
- }
-
- }
-
- if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
- ST(0) = sv_2mortal(vstringify(sv));
- } else {
- ST(0) = sv;
- }
-
- XSRETURN(1);
-}
-
-XS(XS_version_new)
-{
- dVAR;
- dXSARGS;
- if (items > 3)
- croak_xs_usage(cv, "class, version");
- SP -= items;
- {
- SV *vs = ST(1);
- SV *rv;
- const char * const classname =
- sv_isobject(ST(0)) /* get the class if called as an object method */
- ? HvNAME(SvSTASH(SvRV(ST(0))))
- : (char *)SvPV_nolen(ST(0));
-
- if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
- /* create empty object */
- vs = sv_newmortal();
- sv_setpvs(vs, "0");
- }
- else if ( items == 3 ) {
- vs = sv_newmortal();
- Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
- }
-
- rv = new_version(vs);
- if ( strcmp(classname,"version") != 0 ) /* inherited new() */
- sv_bless(rv, gv_stashpv(classname, GV_ADD));
-
- mPUSHs(rv);
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_stringify)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- mPUSHs(vstringify(lobj));
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_numify)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- mPUSHs(vnumify(lobj));
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_normal)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- mPUSHs(vnormal(lobj));
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_vcmp)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- {
- SV * lobj = ST(0);
-
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
- lobj = SvRV(lobj);
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-
- {
- SV *rs;
- SV *rvs;
- SV * robj = ST(1);
- const IV swap = (IV)SvIV(ST(2));
-
- if ( ! sv_derived_from(robj, "version") )
- {
- robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
- sv_2mortal(robj);
- }
- rvs = SvRV(robj);
-
- if ( swap )
- {
- rs = newSViv(vcmp(rvs,lobj));
- }
- else
- {
- rs = newSViv(vcmp(lobj,rvs));
- }
-
- mPUSHs(rs);
- }
-
- PUTBACK;
- return;
- }
-}
-
-XS(XS_version_boolean)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
- SV * const lobj = SvRV(ST(0));
- SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
- mPUSHs(rs);
- PUTBACK;
- return;
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-}
-
-XS(XS_version_noop)
-{
- dVAR;
- dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
- Perl_croak(aTHX_ "operation not supported with version object");
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-#ifndef HASATTRIBUTE_NORETURN
- XSRETURN_EMPTY;
-#endif
-}
-
-XS(XS_version_is_alpha)
-{
- dVAR;
- dXSARGS;
- if (items != 1)
- croak_xs_usage(cv, "lobj");
- SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
- SV * const lobj = ST(0);
- if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
- PUTBACK;
- return;
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-}
-
-XS(XS_version_qv)
-{
- dVAR;
- dXSARGS;
- PERL_UNUSED_ARG(cv);
- SP -= items;
- {
- SV * ver = ST(0);
- SV * rv;
- const char * classname = "";
- if ( items == 2 && SvOK(ST(1)) ) {
- /* getting called as object or class method */
- ver = ST(1);
- classname =
- sv_isobject(ST(0)) /* class called as an object method */
- ? HvNAME_get(SvSTASH(SvRV(ST(0))))
- : (char *)SvPV_nolen(ST(0));
- }
- if ( !SvVOK(ver) ) { /* not already a v-string */
- rv = sv_newmortal();
- sv_setsv(rv,ver); /* make a duplicate */
- upg_version(rv, TRUE);
- } else {
- rv = sv_2mortal(new_version(ver));
- }
- if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
- sv_bless(rv, gv_stashpv(classname, GV_ADD));
- }
- PUSHs(rv);
- }
- PUTBACK;
- return;
-}
-
-XS(XS_version_is_qv)
-{
- dVAR;
- dXSARGS;
- if (items != 1)
- croak_xs_usage(cv, "lobj");
- SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
- SV * const lobj = ST(0);
- if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
- XSRETURN_YES;
- else
- XSRETURN_NO;
- PUTBACK;
- return;
- }
- else
- Perl_croak(aTHX_ "lobj is not of type version");
-}
-