This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[rt.cpan.org #88495] version->new str cmp bug
[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;
172 if (items > 3 || items < 1)
173 croak_xs_usage(cv, "class, version");
174 SP -= items;
175 {
176 SV *vs = ST(1);
177 SV *rv;
178 STRLEN len;
179 const char *classname;
180 U32 flags;
181
182 /* Just in case this is something like a tied hash */
183 SvGETMAGIC(vs);
184
185 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
186 const HV * stash = SvSTASH(SvRV(ST(0)));
187 classname = HvNAME(stash);
188 len = HvNAMELEN(stash);
189 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
190 }
191 else {
192 classname = SvPV(ST(0), len);
193 flags = SvUTF8(ST(0));
194 }
195
196 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
197 /* create empty object */
198 vs = sv_newmortal();
199 sv_setpvs(vs, "0");
200 }
201 else if ( items == 3 ) {
202 vs = sv_newmortal();
203 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
204 }
205
206 rv = new_version(vs);
11e14f5a
FC
207 if ( len != 7
208 || strnNE(classname,"version", len) ) /* inherited new() */
abc6d738
FC
209 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
210
211 mPUSHs(rv);
212 PUTBACK;
213 return;
214 }
215}
216
217XS(XS_version_stringify)
218{
219 dVAR;
220 dXSARGS;
221 if (items < 1)
222 croak_xs_usage(cv, "lobj, ...");
223 SP -= items;
224 {
225 SV * lobj = ST(0);
226
227 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
228 lobj = SvRV(lobj);
229 }
230 else
231 Perl_croak(aTHX_ "lobj is not of type version");
232
233 mPUSHs(vstringify(lobj));
234
235 PUTBACK;
236 return;
237 }
238}
239
240XS(XS_version_numify)
241{
242 dVAR;
243 dXSARGS;
244 if (items < 1)
245 croak_xs_usage(cv, "lobj, ...");
246 SP -= items;
247 {
248 SV * lobj = ST(0);
249
250 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
251 lobj = SvRV(lobj);
252 }
253 else
254 Perl_croak(aTHX_ "lobj is not of type version");
255
256 mPUSHs(vnumify(lobj));
257
258 PUTBACK;
259 return;
260 }
261}
262
263XS(XS_version_normal)
264{
265 dVAR;
266 dXSARGS;
267 if (items < 1)
268 croak_xs_usage(cv, "lobj, ...");
269 SP -= items;
270 {
271 SV * lobj = ST(0);
272
273 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
274 lobj = SvRV(lobj);
275 }
276 else
277 Perl_croak(aTHX_ "lobj is not of type version");
278
279 mPUSHs(vnormal(lobj));
280
281 PUTBACK;
282 return;
283 }
284}
285
286XS(XS_version_vcmp)
287{
288 dVAR;
289 dXSARGS;
290 if (items < 1)
291 croak_xs_usage(cv, "lobj, ...");
292 SP -= items;
293 {
294 SV * lobj = ST(0);
295
296 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
297 lobj = SvRV(lobj);
298 }
299 else
300 Perl_croak(aTHX_ "lobj is not of type version");
301
302 {
303 SV *rs;
304 SV *rvs;
305 SV * robj = ST(1);
306 const IV swap = (IV)SvIV(ST(2));
307
308 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
309 {
310 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
311 sv_2mortal(robj);
312 }
313 rvs = SvRV(robj);
314
315 if ( swap )
316 {
317 rs = newSViv(vcmp(rvs,lobj));
318 }
319 else
320 {
321 rs = newSViv(vcmp(lobj,rvs));
322 }
323
324 mPUSHs(rs);
325 }
326
327 PUTBACK;
328 return;
329 }
330}
331
332XS(XS_version_boolean)
333{
334 dVAR;
335 dXSARGS;
336 if (items < 1)
337 croak_xs_usage(cv, "lobj, ...");
338 SP -= items;
339 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
340 SV * const lobj = SvRV(ST(0));
341 SV * const rs =
342 newSViv( vcmp(lobj,
343 sv_2mortal(new_version(
344 sv_2mortal(newSVpvs("0"))
345 ))
346 )
347 );
348 mPUSHs(rs);
349 PUTBACK;
350 return;
351 }
352 else
353 Perl_croak(aTHX_ "lobj is not of type version");
354}
355
356XS(XS_version_noop)
357{
358 dVAR;
359 dXSARGS;
360 if (items < 1)
361 croak_xs_usage(cv, "lobj, ...");
362 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
363 Perl_croak(aTHX_ "operation not supported with version object");
364 else
365 Perl_croak(aTHX_ "lobj is not of type version");
366#ifndef HASATTRIBUTE_NORETURN
367 XSRETURN_EMPTY;
368#endif
369}
370
371XS(XS_version_is_alpha)
372{
373 dVAR;
374 dXSARGS;
375 if (items != 1)
376 croak_xs_usage(cv, "lobj");
377 SP -= items;
378 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
379 SV * const lobj = ST(0);
380 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
381 XSRETURN_YES;
382 else
383 XSRETURN_NO;
384 PUTBACK;
385 return;
386 }
387 else
388 Perl_croak(aTHX_ "lobj is not of type version");
389}
390
391XS(XS_version_qv)
392{
393 dVAR;
394 dXSARGS;
395 PERL_UNUSED_ARG(cv);
396 SP -= items;
397 {
398 SV * ver = ST(0);
399 SV * rv;
400 STRLEN len = 0;
401 const char * classname = "";
402 U32 flags = 0;
403 if ( items == 2 ) {
404 SvGETMAGIC(ST(1));
405 if (SvOK(ST(1))) {
406 ver = ST(1);
407 }
408 else {
409 Perl_croak(aTHX_ "Invalid version format (version required)");
410 }
411 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
412 const HV * stash = SvSTASH(SvRV(ST(0)));
413 classname = HvNAME(stash);
414 len = HvNAMELEN(stash);
415 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
416 }
417 else {
418 classname = SvPV(ST(0), len);
419 flags = SvUTF8(ST(0));
420 }
421 }
422 if ( !SvVOK(ver) ) { /* not already a v-string */
423 rv = sv_newmortal();
424 sv_setsv(rv,ver); /* make a duplicate */
425 upg_version(rv, TRUE);
426 } else {
427 rv = sv_2mortal(new_version(ver));
428 }
429 if ( items == 2
430 && strnNE(classname,"version", len) ) { /* inherited new() */
431 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
432 }
433 PUSHs(rv);
434 }
435 PUTBACK;
436 return;
437}
438
439XS(XS_version_is_qv)
440{
441 dVAR;
442 dXSARGS;
443 if (items != 1)
444 croak_xs_usage(cv, "lobj");
445 SP -= items;
446 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
447 SV * const lobj = ST(0);
448 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
449 XSRETURN_YES;
450 else
451 XSRETURN_NO;
452 PUTBACK;
453 return;
454 }
455 else
456 Perl_croak(aTHX_ "lobj is not of type version");
457}
458
459#endif