This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Grab latest changes from CPAN 0.9905
[perl5.git] / vxs.inc
CommitLineData
abc6d738
FC
1/* This file is part of the "version" CPAN distribution. Please avoid
2 editing it in the perl core. */
3
b42aaea1
FC
4#ifdef PERL_CORE
5# define VXS_CLASS "version"
72f4d256 6# define VXSp(name) XS_##name
b42aaea1
FC
7#else
8# define VXS_CLASS "version::vxs"
72f4d256 9# define VXSp(name) VXS_##name
b42aaea1 10#endif
72f4d256 11#define VXS(name) XS(VXSp(name))
b42aaea1 12
abc6d738 13#ifdef VXS_XSUB_DETAILS
b42aaea1 14# ifdef PERL_CORE
abc6d738 15 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
b42aaea1 16# else
72f4d256 17 {VXS_CLASS "::_VERSION", VXS_UNIVERSAL_VERSION, NULL},
b42aaea1 18# endif
72f4d256
FC
19 {VXS_CLASS "::()", VXSp(version_noop), NULL},
20 {VXS_CLASS "::new", VXSp(version_new), NULL},
21 {VXS_CLASS "::parse", VXSp(version_new), NULL},
22 {VXS_CLASS "::(\"\"", VXSp(version_stringify), NULL},
23 {VXS_CLASS "::stringify", VXSp(version_stringify), NULL},
24 {VXS_CLASS "::(0+", VXSp(version_numify), NULL},
25 {VXS_CLASS "::numify", VXSp(version_numify), NULL},
26 {VXS_CLASS "::normal", VXSp(version_normal), NULL},
27 {VXS_CLASS "::(cmp", VXSp(version_vcmp), NULL},
28 {VXS_CLASS "::(<=>", VXSp(version_vcmp), NULL},
b42aaea1
FC
29# ifdef PERL_CORE
30 {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
31# else
72f4d256 32 {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL},
b42aaea1 33# endif
72f4d256
FC
34 {VXS_CLASS "::(bool", VXSp(version_boolean), NULL},
35 {VXS_CLASS "::boolean", VXSp(version_boolean), NULL},
36 {VXS_CLASS "::(+", VXSp(version_noop), NULL},
37 {VXS_CLASS "::(-", VXSp(version_noop), NULL},
38 {VXS_CLASS "::(*", VXSp(version_noop), NULL},
39 {VXS_CLASS "::(/", VXSp(version_noop), NULL},
40 {VXS_CLASS "::(+=", VXSp(version_noop), NULL},
41 {VXS_CLASS "::(-=", VXSp(version_noop), NULL},
42 {VXS_CLASS "::(*=", VXSp(version_noop), NULL},
43 {VXS_CLASS "::(/=", VXSp(version_noop), NULL},
44 {VXS_CLASS "::(abs", VXSp(version_noop), NULL},
45 {VXS_CLASS "::(nomethod", VXSp(version_noop), NULL},
46 {VXS_CLASS "::noop", VXSp(version_noop), NULL},
47 {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), NULL},
48 {VXS_CLASS "::qv", VXSp(version_qv), NULL},
49 {VXS_CLASS "::declare", VXSp(version_qv), NULL},
50 {VXS_CLASS "::is_qv", VXSp(version_is_qv), NULL},
abc6d738
FC
51#else
52
04df8d4d
FC
53#ifndef dVAR
54# define dVAR
55#endif
56
0c96c511
FC
57#ifdef HvNAME_HEK
58typedef HEK HVNAME;
59# ifndef HEKf
60# define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg))))
61# define HEKf SVf
62# endif
63#else
64typedef char HVNAME;
65# define HvNAME_HEK HvNAME_get
66# define HEKfARG(arg) arg
67# define HEKf "s"
68#endif
69
72f4d256 70VXS(UNIVERSAL_VERSION)
abc6d738
FC
71{
72 dVAR;
73 dXSARGS;
74 HV *pkg;
75 GV **gvp;
76 GV *gv;
0c96c511 77 SV *ret;
abc6d738
FC
78 SV *sv;
79 const char *undef;
80 PERL_UNUSED_ARG(cv);
81
8372457d
FC
82 if (items < 1)
83 Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
84
0c96c511
FC
85 sv = ST(0);
86
87 if (SvROK(sv)) {
88 sv = (SV*)SvRV(sv);
abc6d738
FC
89 if (!SvOBJECT(sv))
90 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
91 pkg = SvSTASH(sv);
92 }
93 else {
0c96c511 94 pkg = gv_stashsv(sv, FALSE);
abc6d738
FC
95 }
96
0c96c511 97 gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
abc6d738
FC
98
99 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
0c96c511 100 sv = sv_mortalcopy(sv);
4141ef59 101 if ( ! ISA_CLASS_OBJ(sv, "version"))
0c96c511 102 UPG_VERSION(sv, FALSE);
abc6d738
FC
103 undef = NULL;
104 }
105 else {
0c96c511 106 sv = ret = &PL_sv_undef;
abc6d738
FC
107 undef = "(undef)";
108 }
109
110 if (items > 1) {
111 SV *req = ST(1);
112
113 if (undef) {
114 if (pkg) {
0c96c511
FC
115 const HVNAME* const name = HvNAME_HEK(pkg);
116#if PERL_VERSION == 5
117 Perl_croak(aTHX_ "%s version %s required--this is only version ",
118 name, SvPVx_nolen_const(req));
119#else
abc6d738
FC
120 Perl_croak(aTHX_
121 "%"HEKf" does not define $%"HEKf
122 "::VERSION--version check failed",
123 HEKfARG(name), HEKfARG(name));
0c96c511
FC
124#endif
125 }
126 else {
127#if PERL_VERSION >= 8
abc6d738
FC
128 Perl_croak(aTHX_
129 "%"SVf" defines neither package nor VERSION--version check failed",
0c96c511
FC
130 (void*)(ST(0)) );
131#else
132 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
133 SvPVx_nolen_const(ST(0)),
134 SvPVx_nolen_const(ST(0)) );
135#endif
abc6d738
FC
136 }
137 }
138
0c96c511 139 if ( ! ISA_CLASS_OBJ(req, "version")) {
abc6d738 140 /* req may very well be R/O, so create a new object */
0c96c511 141 req = sv_2mortal( NEW_VERSION(req) );
abc6d738
FC
142 }
143
0c96c511 144 if ( VCMP( req, sv ) > 0 ) {
abc6d738 145 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
0c96c511
FC
146 req = VNORMAL(req);
147 sv = VNORMAL(sv);
148 }
149 else {
150 req = VSTRINGIFY(req);
151 sv = VSTRINGIFY(sv);
abc6d738 152 }
0c96c511
FC
153 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
154 "this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)),
155 SVfARG(sv_2mortal(req)),
156 SVfARG(sv_2mortal(sv)));
abc6d738
FC
157 }
158 }
0c96c511 159 ST(0) = ret;
abc6d738 160
0c96c511
FC
161 /* if the package's $VERSION is not undef, it is upgraded to be a version object */
162 if (ISA_CLASS_OBJ(sv, "version")) {
163 ST(0) = sv_2mortal(VSTRINGIFY(sv));
abc6d738
FC
164 } else {
165 ST(0) = sv;
166 }
167
168 XSRETURN(1);
169}
170
72f4d256 171VXS(version_new)
abc6d738
FC
172{
173 dVAR;
174 dXSARGS;
e1c774b6
FC
175 PERL_UNUSED_VAR(cv);
176 SV *vs = items ? ST(1) : &PL_sv_undef;
177 SV *rv;
178 const char * classname = "";
179 STRLEN len;
180 U32 flags = 0;
abc6d738 181 SP -= items;
abc6d738 182
e1c774b6
FC
183 if (items > 3 || items == 0)
184 Perl_croak(aTHX_ "Usage: version::new(class, version)");
abc6d738 185
e1c774b6
FC
186 /* Just in case this is something like a tied hash */
187 SvGETMAGIC(vs);
188
189 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
190 /* create empty object */
191 vs = sv_newmortal();
192 sv_setpvs(vs,"undef");
193 }
194 else if (items == 3 ) {
195 vs = sv_newmortal();
196#if PERL_VERSION == 5
197 sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
198#else
199 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
200#endif
201 }
202 if ( sv_isobject(ST(0)) ) {
203 /* get the class if called as an object method */
204 const HV * stash = SvSTASH(SvRV(ST(0)));
205 classname = HvNAME_get(stash);
206 len = HvNAMELEN_get(stash);
207#ifdef HvNAMEUTF8
208 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
209#endif
210 }
211 else {
212 classname = SvPV(ST(0), len);
213 flags = SvUTF8(ST(0));
abc6d738 214 }
e1c774b6
FC
215
216 rv = NEW_VERSION(vs);
217 if ( len != sizeof(VXS_CLASS)-1
218 || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
219#if PERL_VERSION == 5
220 sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
221#else
222 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
223#endif
224
225 mPUSHs(rv);
226 PUTBACK;
227 return;
abc6d738
FC
228}
229
5d450c46
FC
230#define VTYPECHECK(var, val, varname) \
231 STMT_START { \
232 if (ISA_CLASS_OBJ(val, "version")) { \
233 (var) = SvRV(val); \
234 } \
235 else \
236 Perl_croak(aTHX_ varname " is not of type version"); \
237 } STMT_END
238
72f4d256 239VXS(version_stringify)
abc6d738
FC
240{
241 dVAR;
242 dXSARGS;
243 if (items < 1)
244 croak_xs_usage(cv, "lobj, ...");
245 SP -= items;
246 {
5d450c46
FC
247 SV * lobj;
248 VTYPECHECK(lobj, ST(0), "lobj");
abc6d738 249
5d450c46 250 mPUSHs(VSTRINGIFY(lobj));
abc6d738
FC
251
252 PUTBACK;
253 return;
254 }
255}
256
72f4d256 257VXS(version_numify)
abc6d738
FC
258{
259 dVAR;
260 dXSARGS;
261 if (items < 1)
262 croak_xs_usage(cv, "lobj, ...");
263 SP -= items;
264 {
5d450c46
FC
265 SV * lobj;
266 VTYPECHECK(lobj, ST(0), "lobj");
267 mPUSHs(VNUMIFY(lobj));
abc6d738
FC
268 PUTBACK;
269 return;
270 }
271}
272
72f4d256 273VXS(version_normal)
abc6d738
FC
274{
275 dVAR;
276 dXSARGS;
b47c4431 277 if (items != 1)
5d450c46 278 croak_xs_usage(cv, "ver");
abc6d738
FC
279 SP -= items;
280 {
5d450c46
FC
281 SV * ver;
282 VTYPECHECK(ver, ST(0), "ver");
abc6d738 283
5d450c46 284 mPUSHs(VNORMAL(ver));
abc6d738
FC
285
286 PUTBACK;
287 return;
288 }
289}
290
72f4d256 291VXS(version_vcmp)
abc6d738
FC
292{
293 dVAR;
294 dXSARGS;
295 if (items < 1)
296 croak_xs_usage(cv, "lobj, ...");
297 SP -= items;
298 {
5d450c46
FC
299 SV * lobj;
300 VTYPECHECK(lobj, ST(0), "lobj");
abc6d738
FC
301 {
302 SV *rs;
303 SV *rvs;
304 SV * robj = ST(1);
305 const IV swap = (IV)SvIV(ST(2));
306
4141ef59 307 if ( !ISA_CLASS_OBJ(robj, "version") )
abc6d738 308 {
5d450c46 309 robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
abc6d738
FC
310 sv_2mortal(robj);
311 }
312 rvs = SvRV(robj);
313
314 if ( swap )
315 {
5d450c46 316 rs = newSViv(VCMP(rvs,lobj));
abc6d738
FC
317 }
318 else
319 {
5d450c46 320 rs = newSViv(VCMP(lobj,rvs));
abc6d738
FC
321 }
322
323 mPUSHs(rs);
324 }
325
326 PUTBACK;
327 return;
328 }
329}
330
72f4d256 331VXS(version_boolean)
abc6d738
FC
332{
333 dVAR;
334 dXSARGS;
5d450c46 335 SV *lobj;
abc6d738
FC
336 if (items < 1)
337 croak_xs_usage(cv, "lobj, ...");
338 SP -= items;
5d450c46
FC
339 VTYPECHECK(lobj, ST(0), "lobj");
340 {
abc6d738 341 SV * const rs =
5d450c46
FC
342 newSViv( VCMP(lobj,
343 sv_2mortal(NEW_VERSION(
abc6d738
FC
344 sv_2mortal(newSVpvs("0"))
345 ))
346 )
347 );
348 mPUSHs(rs);
349 PUTBACK;
350 return;
351 }
abc6d738
FC
352}
353
72f4d256 354VXS(version_noop)
abc6d738
FC
355{
356 dVAR;
357 dXSARGS;
358 if (items < 1)
359 croak_xs_usage(cv, "lobj, ...");
5d450c46 360 if (ISA_CLASS_OBJ(ST(0), "version"))
abc6d738
FC
361 Perl_croak(aTHX_ "operation not supported with version object");
362 else
363 Perl_croak(aTHX_ "lobj is not of type version");
abc6d738 364 XSRETURN_EMPTY;
abc6d738
FC
365}
366
72f4d256 367VXS(version_is_alpha)
abc6d738
FC
368{
369 dVAR;
370 dXSARGS;
371 if (items != 1)
372 croak_xs_usage(cv, "lobj");
373 SP -= items;
5d450c46
FC
374 {
375 SV *lobj;
376 VTYPECHECK(lobj, ST(0), "lobj");
0f6a6701 377 if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) )
abc6d738
FC
378 XSRETURN_YES;
379 else
380 XSRETURN_NO;
381 PUTBACK;
382 return;
383 }
abc6d738
FC
384}
385
72f4d256 386VXS(version_qv)
abc6d738
FC
387{
388 dVAR;
389 dXSARGS;
390 PERL_UNUSED_ARG(cv);
391 SP -= items;
392 {
393 SV * ver = ST(0);
394 SV * rv;
395 STRLEN len = 0;
396 const char * classname = "";
397 U32 flags = 0;
398 if ( items == 2 ) {
399 SvGETMAGIC(ST(1));
400 if (SvOK(ST(1))) {
401 ver = ST(1);
402 }
403 else {
404 Perl_croak(aTHX_ "Invalid version format (version required)");
405 }
406 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
407 const HV * stash = SvSTASH(SvRV(ST(0)));
5d450c46
FC
408 classname = HvNAME_get(stash);
409 len = HvNAMELEN_get(stash);
410#ifdef HvNAMEUTF8
abc6d738 411 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
5d450c46 412#endif
abc6d738
FC
413 }
414 else {
415 classname = SvPV(ST(0), len);
416 flags = SvUTF8(ST(0));
417 }
5d450c46 418 }
abc6d738
FC
419 if ( !SvVOK(ver) ) { /* not already a v-string */
420 rv = sv_newmortal();
95a23f5d 421 SvSetSV_nosteal(rv,ver); /* make a duplicate */
5d450c46 422 UPG_VERSION(rv, TRUE);
abc6d738 423 } else {
5d450c46 424 rv = sv_2mortal(NEW_VERSION(ver));
abc6d738 425 }
8a3edca7 426 if ( items == 2 && (len != 7
5d450c46
FC
427 || strcmp(classname,"version")) ) { /* inherited new() */
428#if PERL_VERSION == 5
429 sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
430#else
abc6d738 431 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
5d450c46 432#endif
abc6d738
FC
433 }
434 PUSHs(rv);
435 }
436 PUTBACK;
437 return;
438}
439
72f4d256 440VXS(version_is_qv)
abc6d738
FC
441{
442 dVAR;
443 dXSARGS;
444 if (items != 1)
445 croak_xs_usage(cv, "lobj");
446 SP -= items;
5d450c46
FC
447 {
448 SV *lobj;
449 VTYPECHECK(lobj, ST(0), "lobj");
0f6a6701 450 if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) )
abc6d738
FC
451 XSRETURN_YES;
452 else
453 XSRETURN_NO;
454 PUTBACK;
455 return;
456 }
abc6d738
FC
457}
458
459#endif