/* universal.c
*
- * Copyright (c) 1997-2002, Larry Wall
+ * Copyright (c) 1997-2003, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Can't locate package %s for @%s::ISA",
- SvPVX(sv), HvNAME(stash));
+ "Can't locate package %"SVf" for @%s::ISA",
+ sv, HvNAME(stash));
continue;
}
if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
{
- /* create the package stash for version objects */
- HV *hv = get_hv("version::OVERLOAD",TRUE);
- SV *sv = *hv_fetch(hv,"register",8,1);
- sv_inc(sv);
- SvSETMAGIC(sv);
+ /* register the overloading (type 'A') magic */
+ PL_amagic_generation++;
/* Make it findable via fetchmethod */
newXS("version::()", XS_version_noop, file);
newXS("version::new", XS_version_new, file);
if (SvGMAGICAL(sv))
mg_get(sv);
- if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
+ if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+ || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
XSRETURN_UNDEF;
name = (char *)SvPV(ST(1),n_a);
if (SvGMAGICAL(sv))
mg_get(sv);
- if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
+ if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+ || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
XSRETURN_UNDEF;
name = (char *)SvPV(ST(1),n_a);
"%s defines neither package nor VERSION--version check failed", str);
}
}
- if (!SvNIOK(sv) && SvPOK(sv)) {
- char *str = SvPVx(sv,len);
- while (len) {
- --len;
- /* XXX could DWIM "1.2.3" here */
- if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
- break;
- }
- if (len) {
- if (SvNOK(req) && SvPOK(req)) {
- /* they said C<use Foo v1.2.3> and $Foo::VERSION
- * doesn't look like a float: do string compare */
- if (sv_cmp(req,sv) == 1) {
- Perl_croak(aTHX_ "%s v%"VDf" required--"
- "this is only v%"VDf,
- HvNAME(pkg), req, sv);
- }
- goto finish;
- }
- /* they said C<use Foo 1.002_003> and $Foo::VERSION
- * doesn't look like a float: force numeric compare */
- (void)SvUPGRADE(sv, SVt_PVNV);
- SvNVX(sv) = str_to_version(sv);
- SvPOK_off(sv);
- SvNOK_on(sv);
- }
- }
- /* if we get here, we're looking for a numeric comparison,
- * so force the required version into a float, even if they
- * said C<use Foo v1.2.3> */
- if (SvNOK(req) && SvPOK(req)) {
- NV n = SvNV(req);
- req = sv_newmortal();
- sv_setnv(req, n);
- }
+ if ( !sv_derived_from(sv, "version"))
+ sv = new_version(sv);
+
+ if ( !sv_derived_from(req, "version"))
+ req = new_version(req);
- if (SvNV(req) > SvNV(sv))
- Perl_croak(aTHX_ "%s version %s required--this is only version %s",
- HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
+ if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
+ Perl_croak(aTHX_
+ "%s version %"SVf" required--this is only version %"SVf,
+ HvNAME(pkg), req, sv);
}
-finish:
ST(0) = sv;
XSRETURN(1);
XS(XS_version_new)
{
dXSARGS;
- if (items != 2)
+ if (items > 3)
Perl_croak(aTHX_ "Usage: version::new(class, version)");
SP -= items;
{
/* char * class = (char *)SvPV_nolen(ST(0)); */
- SV * version = ST(1);
-
-{
- PUSHs(new_version(version));
-}
+ SV *version = ST(1);
+ if (items == 3 )
+ {
+ char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
+ version = Perl_newSVpvf(aTHX_ "v%s",vs);
+ }
+ PUSHs(new_version(version));
PUTBACK;
return;
}
Perl_croak(aTHX_ "lobj is not of type version");
{
- SV *vs = NEWSV(92,5);
- if ( lobj == SvRV(PL_patchlevel) )
- sv_catsv(vs,lobj);
- else
- vstringify(vs,lobj);
- PUSHs(vs);
+ PUSHs(vstringify(lobj));
}
PUTBACK;
Perl_croak(aTHX_ "lobj is not of type version");
{
- SV *vs = NEWSV(92,5);
- vnumify(vs,lobj);
- PUSHs(vs);
+ PUSHs(vnumify(lobj));
}
PUTBACK;
if ( swap )
{
- rs = newSViv(sv_cmp(rvs,lobj));
+ rs = newSViv(vcmp(rvs,lobj));
}
else
{
- rs = newSViv(sv_cmp(lobj,rvs));
+ rs = newSViv(vcmp(lobj,rvs));
}
PUSHs(rs);
{
SV *rs;
- rs = newSViv(sv_cmp(lobj,Nullsv));
+ rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
PUSHs(rs);
}