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