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
1 /* This file is part of the "version" CPAN distribution.  Please avoid
2    editing it in the perl core. */
3
4 #ifdef PERL_CORE
5 #  define VXS_CLASS "version"
6 #else
7 #  define VXS_CLASS "version::vxs"
8 #endif
9
10 #ifdef VXS_XSUB_DETAILS
11 #  ifdef PERL_CORE
12     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
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},
48 #else
49
50 #ifndef dVAR
51 #  define dVAR
52 #endif
53
54 #ifdef HvNAME_HEK
55 typedef HEK HVNAME;
56 #  ifndef HEKf
57 #    define HEKfARG(arg)        ((void*)(sv_2mortal(newSVhek(arg))))
58 #    define HEKf                SVf
59 #  endif
60 #else
61 typedef char HVNAME;
62 #  define HvNAME_HEK    HvNAME_get
63 #  define HEKfARG(arg)  arg
64 #  define HEKf          "s"
65 #endif
66
67 XS(XS_UNIVERSAL_VERSION)
68 {
69     dVAR;
70     dXSARGS;
71     HV *pkg;
72     GV **gvp;
73     GV *gv;
74     SV *ret;
75     SV *sv;
76     const char *undef;
77     PERL_UNUSED_ARG(cv);
78
79     if (items < 1)
80        Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
81
82     sv = ST(0);
83
84     if (SvROK(sv)) {
85         sv = (SV*)SvRV(sv);
86         if (!SvOBJECT(sv))
87             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
88         pkg = SvSTASH(sv);
89     }
90     else {
91         pkg = gv_stashsv(sv, FALSE);
92     }
93
94     gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
95
96     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
97         sv = sv_mortalcopy(sv);
98         if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
99             UPG_VERSION(sv, FALSE);
100         undef = NULL;
101     }
102     else {
103         sv = ret = &PL_sv_undef;
104         undef = "(undef)";
105     }
106
107     if (items > 1) {
108         SV *req = ST(1);
109
110         if (undef) {
111             if (pkg) {
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
117                 Perl_croak(aTHX_
118                            "%"HEKf" does not define $%"HEKf
119                            "::VERSION--version check failed",
120                            HEKfARG(name), HEKfARG(name));
121 #endif
122             }
123             else {
124 #if PERL_VERSION >= 8
125                 Perl_croak(aTHX_
126                              "%"SVf" defines neither package nor VERSION--version check failed",
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
133             }
134         }
135
136         if ( ! ISA_CLASS_OBJ(req, "version")) {
137             /* req may very well be R/O, so create a new object */
138             req = sv_2mortal( NEW_VERSION(req) );
139         }
140
141         if ( VCMP( req, sv ) > 0 ) {
142             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
143                 req = VNORMAL(req);
144                 sv  = VNORMAL(sv);
145             }
146             else {
147                 req = VSTRINGIFY(req);
148                 sv  = VSTRINGIFY(sv);
149             }
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)));
154         }
155     }
156     ST(0) = ret;
157
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));
161     } else {
162         ST(0) = sv;
163     }
164
165     XSRETURN(1);
166 }
167
168 XS(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);
207         if ( len != 7
208           || strnNE(classname,"version", len) ) /* inherited new() */
209             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
210
211         mPUSHs(rv);
212         PUTBACK;
213         return;
214     }
215 }
216
217 XS(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
240 XS(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
263 XS(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
286 XS(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
332 XS(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
356 XS(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
371 XS(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
391 XS(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
439 XS(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