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