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