1 /* This file is part of the "version" CPAN distribution. Please avoid
2 editing it in the perl core. */
5 # define VXS_CLASS "version"
6 # define VXSp(name) XS_##name
7 /* VXSXSDP = XSUB Details Proto */
10 # define VXS_CLASS "version::vxs"
11 # define VXSp(name) VXS_##name
12 /* proto member is unused in version, it is used in CORE by non version xsubs */
17 # define XS_INTERNAL(name) static XSPROTO(name)
20 #define VXS(name) XS_INTERNAL(VXSp(name)); XS_INTERNAL(VXSp(name))
22 /* uses PUSHs, so SP must be at start, PUSHs sv on Perl stack, then returns from
23 xsub; this is a little more machine code/tailcall friendly than mPUSHs(foo);
26 #define VXS_RETURN_M_SV(sv) \
36 #ifdef VXS_XSUB_DETAILS
38 {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)},
40 {VXS_CLASS "::_VERSION", VXSp(universal_version), VXSXSDP(NULL)},
41 {VXS_CLASS "::()", VXSp(version_noop), VXSXSDP(NULL)},
42 {VXS_CLASS "::new", VXSp(version_new), VXSXSDP(NULL)},
43 {VXS_CLASS "::parse", VXSp(version_new), VXSXSDP(NULL)},
44 {VXS_CLASS "::(\"\"", VXSp(version_stringify), VXSXSDP(NULL)},
45 {VXS_CLASS "::stringify", VXSp(version_stringify), VXSXSDP(NULL)},
46 {VXS_CLASS "::(0+", VXSp(version_numify), VXSXSDP(NULL)},
47 {VXS_CLASS "::numify", VXSp(version_numify), VXSXSDP(NULL)},
48 {VXS_CLASS "::normal", VXSp(version_normal), VXSXSDP(NULL)},
49 {VXS_CLASS "::(cmp", VXSp(version_vcmp), VXSXSDP(NULL)},
50 {VXS_CLASS "::(<=>", VXSp(version_vcmp), VXSXSDP(NULL)},
52 {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)},
54 {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)},
56 {VXS_CLASS "::(bool", VXSp(version_boolean), VXSXSDP(NULL)},
57 {VXS_CLASS "::boolean", VXSp(version_boolean), VXSXSDP(NULL)},
58 {VXS_CLASS "::(+", VXSp(version_noop), VXSXSDP(NULL)},
59 {VXS_CLASS "::(-", VXSp(version_noop), VXSXSDP(NULL)},
60 {VXS_CLASS "::(*", VXSp(version_noop), VXSXSDP(NULL)},
61 {VXS_CLASS "::(/", VXSp(version_noop), VXSXSDP(NULL)},
62 {VXS_CLASS "::(+=", VXSp(version_noop), VXSXSDP(NULL)},
63 {VXS_CLASS "::(-=", VXSp(version_noop), VXSXSDP(NULL)},
64 {VXS_CLASS "::(*=", VXSp(version_noop), VXSXSDP(NULL)},
65 {VXS_CLASS "::(/=", VXSp(version_noop), VXSXSDP(NULL)},
66 {VXS_CLASS "::(abs", VXSp(version_noop), VXSXSDP(NULL)},
67 {VXS_CLASS "::(nomethod", VXSp(version_noop), VXSXSDP(NULL)},
68 {VXS_CLASS "::noop", VXSp(version_noop), VXSXSDP(NULL)},
69 {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), VXSXSDP(NULL)},
70 {VXS_CLASS "::qv", VXSp(version_qv), VXSXSDP(NULL)},
71 {VXS_CLASS "::declare", VXSp(version_qv), VXSXSDP(NULL)},
72 {VXS_CLASS "::is_qv", VXSp(version_is_qv), VXSXSDP(NULL)},
82 # define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg))))
87 # define HvNAME_HEK HvNAME_get
88 # define HEKfARG(arg) arg
92 VXS(universal_version)
103 Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
110 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
114 pkg = gv_stashsv(sv, FALSE);
117 gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
119 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
120 sv = sv_mortalcopy(sv);
121 if ( ! ISA_VERSION_OBJ(sv) )
122 UPG_VERSION(sv, FALSE);
135 const HVNAME* const name = HvNAME_HEK(pkg);
136 #if PERL_VERSION == 5
137 Perl_croak(aTHX_ "%s version %s required--this is only version ",
138 name, SvPVx_nolen_const(req));
141 "%" HEKf " does not define $%" HEKf
142 "::VERSION--version check failed",
143 HEKfARG(name), HEKfARG(name));
147 #if PERL_VERSION >= 8
149 "%" SVf " defines neither package nor VERSION--"
150 "version check failed",
153 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
154 SvPVx_nolen_const(ST(0)),
155 SvPVx_nolen_const(ST(0)) );
160 if ( ! ISA_VERSION_OBJ(req) ) {
161 /* req may very well be R/O, so create a new object */
162 req = sv_2mortal( NEW_VERSION(req) );
165 if ( VCMP( req, sv ) > 0 ) {
166 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
171 req = VSTRINGIFY(req);
174 Perl_croak(aTHX_ "%" HEKf " version %" SVf " required--"
175 "this is only version %" SVf, HEKfARG(HvNAME_HEK(pkg)),
176 SVfARG(sv_2mortal(req)),
177 SVfARG(sv_2mortal(sv)));
181 /* if the package's $VERSION is not undef, it is upgraded to be a version object */
182 if (ISA_VERSION_OBJ(sv)) {
183 ST(0) = sv_2mortal(VSTRINGIFY(sv));
196 const char * classname = "";
209 #if PERL_VERSION == 5
210 sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2));
212 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
218 /* Just in case this is something like a tied hash */
224 /* no param or explicit undef */
225 /* create empty object */
227 sv_setpvs(vs,"undef");
231 Perl_croak_nocontext("Usage: version::new(class, version)");
235 if ( sv_isobject(svarg0) ) {
236 /* get the class if called as an object method */
237 const HV * stash = SvSTASH(SvRV(svarg0));
238 classname = HvNAME_get(stash);
239 len = HvNAMELEN_get(stash);
241 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
245 classname = SvPV_nomg(svarg0, len);
246 flags = SvUTF8(svarg0);
249 rv = NEW_VERSION(vs);
250 if ( len != sizeof(VXS_CLASS)-1
251 || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
252 #if PERL_VERSION == 5
253 sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
255 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
261 #define VTYPECHECK(var, val, varname) \
264 if (ISA_VERSION_OBJ(sv_vtc)) { \
265 (var) = SvRV(sv_vtc); \
268 Perl_croak_nocontext(varname " is not of type version"); \
271 VXS(version_stringify)
275 croak_xs_usage(cv, "lobj, ...");
279 VTYPECHECK(lobj, ST(0), "lobj");
281 VXS_RETURN_M_SV(VSTRINGIFY(lobj));
289 croak_xs_usage(cv, "lobj, ...");
293 VTYPECHECK(lobj, ST(0), "lobj");
294 VXS_RETURN_M_SV(VNUMIFY(lobj));
302 croak_xs_usage(cv, "ver");
306 VTYPECHECK(ver, ST(0), "ver");
308 VXS_RETURN_M_SV(VNORMAL(ver));
316 croak_xs_usage(cv, "lobj, ...");
320 VTYPECHECK(lobj, ST(0), "lobj");
325 const IV swap = (IV)SvIV(ST(2));
327 if ( !ISA_VERSION_OBJ(robj) )
329 robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)));
335 rs = newSViv(VCMP(rvs,lobj));
339 rs = newSViv(VCMP(lobj,rvs));
352 croak_xs_usage(cv, "lobj, ...");
354 VTYPECHECK(lobj, ST(0), "lobj");
358 sv_2mortal(NEW_VERSION(
359 sv_2mortal(newSVpvs("0"))
371 croak_xs_usage(cv, "lobj, ...");
372 if (ISA_VERSION_OBJ(ST(0)))
373 Perl_croak(aTHX_ "operation not supported with version object");
375 Perl_croak(aTHX_ "lobj is not of type version");
381 S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
385 croak_xs_usage(cv, "lobj");
389 VTYPECHECK(lobj, lobj, "lobj");
390 if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) )
400 VXS(version_is_alpha)
402 S_version_check_key(aTHX_ cv, "alpha", 5);
415 const char * classname = "";
424 Perl_croak(aTHX_ "Invalid version format (version required)");
426 if ( sv_isobject(sv0) ) { /* class called as an object method */
427 const HV * stash = SvSTASH(SvRV(sv0));
428 classname = HvNAME_get(stash);
429 len = HvNAMELEN_get(stash);
431 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
435 classname = SvPV(sv0, len);
439 if ( !SvVOK(ver) ) { /* not already a v-string */
441 SvSetSV_nosteal(rv,ver); /* make a duplicate */
442 UPG_VERSION(rv, TRUE);
444 rv = sv_2mortal(NEW_VERSION(ver));
446 if ( items == 2 && (len != 7
447 || strcmp(classname,"version")) ) { /* inherited new() */
448 #if PERL_VERSION == 5
449 sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
451 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
463 S_version_check_key(aTHX_ cv, "qv", 2);