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
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     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;
178     SP -= items;
179
180     if (items > 3 || items == 0)
181         Perl_croak(aTHX_ "Usage: version::new(class, version)");
182
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));
211     }
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;
225 }
226
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
236 XS(XS_version_stringify)
237 {
238      dVAR;
239      dXSARGS;
240      if (items < 1)
241          croak_xs_usage(cv, "lobj, ...");
242      SP -= items;
243      {
244           SV *  lobj;
245           VTYPECHECK(lobj, ST(0), "lobj");
246
247           mPUSHs(VSTRINGIFY(lobj));
248
249           PUTBACK;
250           return;
251      }
252 }
253
254 XS(XS_version_numify)
255 {
256      dVAR;
257      dXSARGS;
258      if (items < 1)
259          croak_xs_usage(cv, "lobj, ...");
260      SP -= items;
261      {
262           SV *  lobj;
263           VTYPECHECK(lobj, ST(0), "lobj");
264           mPUSHs(VNUMIFY(lobj));
265           PUTBACK;
266           return;
267      }
268 }
269
270 XS(XS_version_normal)
271 {
272      dVAR;
273      dXSARGS;
274      if (items != 1)
275          croak_xs_usage(cv, "ver");
276      SP -= items;
277      {
278           SV *  ver;
279           VTYPECHECK(ver, ST(0), "ver");
280
281           mPUSHs(VNORMAL(ver));
282
283           PUTBACK;
284           return;
285      }
286 }
287
288 XS(XS_version_vcmp)
289 {
290      dVAR;
291      dXSARGS;
292      if (items < 1)
293          croak_xs_usage(cv, "lobj, ...");
294      SP -= items;
295      {
296           SV *  lobj;
297           VTYPECHECK(lobj, ST(0), "lobj");
298           {
299                SV       *rs;
300                SV       *rvs;
301                SV * robj = ST(1);
302                const IV  swap = (IV)SvIV(ST(2));
303
304                if ( !ISA_CLASS_OBJ(robj, "version::vxs") )
305                {
306                     robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
307                     sv_2mortal(robj);
308                }
309                rvs = SvRV(robj);
310
311                if ( swap )
312                {
313                     rs = newSViv(VCMP(rvs,lobj));
314                }
315                else
316                {
317                     rs = newSViv(VCMP(lobj,rvs));
318                }
319
320                mPUSHs(rs);
321           }
322
323           PUTBACK;
324           return;
325      }
326 }
327
328 XS(XS_version_boolean)
329 {
330     dVAR;
331     dXSARGS;
332     SV *lobj;
333     if (items < 1)
334         croak_xs_usage(cv, "lobj, ...");
335     SP -= items;
336     VTYPECHECK(lobj, ST(0), "lobj");
337     {
338         SV * const rs =
339             newSViv( VCMP(lobj,
340                           sv_2mortal(NEW_VERSION(
341                                         sv_2mortal(newSVpvs("0"))
342                                     ))
343                          )
344                    );
345         mPUSHs(rs);
346         PUTBACK;
347         return;
348     }
349 }
350
351 XS(XS_version_noop)
352 {
353     dVAR;
354     dXSARGS;
355     if (items < 1)
356         croak_xs_usage(cv, "lobj, ...");
357     if (ISA_CLASS_OBJ(ST(0), "version"))
358         Perl_croak(aTHX_ "operation not supported with version object");
359     else
360         Perl_croak(aTHX_ "lobj is not of type version");
361     XSRETURN_EMPTY;
362 }
363
364 XS(XS_version_is_alpha)
365 {
366     dVAR;
367     dXSARGS;
368     if (items != 1)
369         croak_xs_usage(cv, "lobj");
370     SP -= items;
371     {
372         SV *lobj;
373         VTYPECHECK(lobj, ST(0), "lobj");
374         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
375             XSRETURN_YES;
376         else
377             XSRETURN_NO;
378         PUTBACK;
379         return;
380     }
381 }
382
383 XS(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)));
405                 classname = HvNAME_get(stash);
406                 len       = HvNAMELEN_get(stash);
407 #ifdef HvNAMEUTF8
408                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
409 #endif
410             }
411             else {
412                classname = SvPV(ST(0), len);
413                 flags     = SvUTF8(ST(0));
414             }
415         }
416         if ( !SvVOK(ver) ) { /* not already a v-string */
417             rv = sv_newmortal();
418             sv_setsv(rv,ver); /* make a duplicate */
419             UPG_VERSION(rv, TRUE);
420         } else {
421             rv = sv_2mortal(NEW_VERSION(ver));
422         }
423         if ( items == 2 && (len != 7
424                 || strcmp(classname,"version")) ) { /* inherited new() */
425 #if PERL_VERSION == 5
426             sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
427 #else
428             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
429 #endif
430         }
431         PUSHs(rv);
432     }
433     PUTBACK;
434     return;
435 }
436
437 XS(XS_version_is_qv)
438 {
439     dVAR;
440     dXSARGS;
441     if (items != 1)
442         croak_xs_usage(cv, "lobj");
443     SP -= items;
444     {
445         SV *lobj;
446         VTYPECHECK(lobj, ST(0), "lobj");
447         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
448             XSRETURN_YES;
449         else
450             XSRETURN_NO;
451         PUTBACK;
452         return;
453     }
454 }
455
456 #endif