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