#include "EXTERN.h" #include "perl.h" #include "XSUB.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::(nomethod", XS_version__vxs_noop, file); newXS("UNIVERSAL::VERSION", XS_version__vxs_VERSION, file); void new(...) PPCODE: { SV *vs = ST(1); SV *rv; char *class; /* get the class if called as an object method */ if ( sv_isobject(ST(0)) ) { class = HvNAME(SvSTASH(SvRV(ST(0)))); } else { class = (char *)SvPV_nolen(ST(0)); } if (items == 3 ) { STRLEN n_a; vs = sv_newmortal(); sv_setpvf(vs,"v%s",SvPV(ST(2),n_a)); } if ( items == 1 ) { /* no parameter provided */ if ( sv_isobject(ST(0)) ) { /* create empty object */ vs = sv_newmortal(); sv_setpv(vs,""); } } rv = new_version(vs); if ( strcmp(class,"version::vxs") != 0 ) /* inherited new() */ sv_bless(rv, gv_stashpv(class,TRUE)); PUSHs(sv_2mortal(rv)); } void stringify (lobj,...) version_vxs lobj PPCODE: { PUSHs(sv_2mortal(vstringify(lobj))); } void numify (lobj,...) version_vxs lobj PPCODE: { PUSHs(sv_2mortal(vnumify(lobj))); } void vcmp (lobj,...) version_vxs lobj PPCODE: { SV *rs; SV * robj = ST(1); IV swap = (IV)SvIV(ST(2)); if ( ! sv_derived_from(robj, "version::vxs") ) { robj = sv_2mortal(new_version(robj)); } if ( swap ) { rs = newSViv(vcmp(robj,lobj)); } else { rs = newSViv(vcmp(lobj,robj)); } PUSHs(sv_2mortal(rs)); } void boolean(lobj,...) version_vxs lobj PPCODE: { SV *rs; rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); PUSHs(sv_2mortal(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((HV*)SvRV(lobj), "alpha", 5 ) ) XSRETURN_YES; else XSRETURN_NO; } void qv(ver) SV *ver PPCODE: { #ifdef SvVOK if ( !SvVOK(ver) ) { /* not already a v-string */ #endif SV *vs = sv_newmortal(); char *version; if ( SvNOK(ver) ) /* may get too much accuracy */ { char tbuf[64]; sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); version = savepv(tbuf); } else { STRLEN n_a; version = savepv(SvPV(ver,n_a)); } (void)scan_version(version,vs,TRUE); Safefree(version); PUSHs(vs); #ifdef SvVOK } else { PUSHs(sv_2mortal(new_version(ver))); } #endif } void normal(ver) SV *ver PPCODE: { PUSHs(sv_2mortal(vnormal(ver))); } void VERSION(sv,...) SV *sv PPCODE: { HV *pkg; GV **gvp; GV *gv; 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_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { SV *nsv = sv_newmortal(); sv_setsv(nsv, sv); sv = nsv; if ( !sv_derived_from(sv, "version::vxs")) upg_version(sv); undef = Nullch; } else { sv = (SV*)&PL_sv_undef; undef = "(undef)"; } if (items > 1) { SV *req = ST(1); STRLEN len; if (undef) { if (pkg) Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", HvNAME(pkg), HvNAME(pkg)); else { char *str = SvPVx(ST(0), len); Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed", str); } } if ( !sv_derived_from(req, "version::vxs")) { /* req may very well be R/O, so create a new object */ SV *nsv = sv_newmortal(); sv_setsv(nsv, req); req = nsv; upg_version(req); } if ( vcmp( req, sv ) > 0 ) Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" "this is only version %"SVf" (%"SVf")", HvNAME(pkg), vnumify(req),vnormal(req),vnumify(sv),vnormal(sv)); } if ( SvOK(sv) && sv_derived_from(sv, "version::vxs") ) PUSHs(vnumify(sv)); else PUSHs(sv); XSRETURN(1); }