This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
vxs.inc: Don’t hard-code class name
[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 XS(XS_UNIVERSAL_VERSION)
51 {
52     dVAR;
53     dXSARGS;
54     HV *pkg;
55     GV **gvp;
56     GV *gv;
57     SV *sv;
58     const char *undef;
59     PERL_UNUSED_ARG(cv);
60
61     if (SvROK(ST(0))) {
62         sv = MUTABLE_SV(SvRV(ST(0)));
63         if (!SvOBJECT(sv))
64             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
65         pkg = SvSTASH(sv);
66     }
67     else {
68         pkg = gv_stashsv(ST(0), 0);
69     }
70
71     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
72
73     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
74         SV * const nsv = sv_newmortal();
75         sv_setsv(nsv, sv);
76         sv = nsv;
77         if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
78             upg_version(sv, FALSE);
79
80         undef = NULL;
81     }
82     else {
83         sv = &PL_sv_undef;
84         undef = "(undef)";
85     }
86
87     if (items > 1) {
88         SV *req = ST(1);
89
90         if (undef) {
91             if (pkg) {
92                 const HEK * const name = HvNAME_HEK(pkg);
93                 Perl_croak(aTHX_
94                            "%"HEKf" does not define $%"HEKf
95                            "::VERSION--version check failed",
96                            HEKfARG(name), HEKfARG(name));
97             } else {
98                 Perl_croak(aTHX_
99                              "%"SVf" defines neither package nor VERSION--version check failed",
100                              SVfARG(ST(0)) );
101             }
102         }
103
104         if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
105             /* req may very well be R/O, so create a new object */
106             req = sv_2mortal( new_version(req) );
107         }
108
109         if ( vcmp( req, sv ) > 0 ) {
110             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
111                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
112                        "this is only version %"SVf"",
113                        HEKfARG(HvNAME_HEK(pkg)),
114                        SVfARG(sv_2mortal(vnormal(req))),
115                        SVfARG(sv_2mortal(vnormal(sv))));
116             } else {
117                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
118                        "this is only version %"SVf,
119                        HEKfARG(HvNAME_HEK(pkg)),
120                        SVfARG(sv_2mortal(vstringify(req))),
121                        SVfARG(sv_2mortal(vstringify(sv))));
122             }
123         }
124     }
125
126     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
127         ST(0) = sv_2mortal(vstringify(sv));
128     } else {
129         ST(0) = sv;
130     }
131
132     XSRETURN(1);
133 }
134
135 XS(XS_version_new)
136 {
137     dVAR;
138     dXSARGS;
139     if (items > 3 || items < 1)
140         croak_xs_usage(cv, "class, version");
141     SP -= items;
142     {
143         SV *vs = ST(1);
144         SV *rv;
145         STRLEN len;
146         const char *classname;
147         U32 flags;
148
149         /* Just in case this is something like a tied hash */
150         SvGETMAGIC(vs);
151
152         if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
153             const HV * stash = SvSTASH(SvRV(ST(0)));
154             classname = HvNAME(stash);
155             len       = HvNAMELEN(stash);
156             flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
157         }
158         else {
159             classname = SvPV(ST(0), len);
160             flags     = SvUTF8(ST(0));
161         }
162
163         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
164             /* create empty object */
165             vs = sv_newmortal();
166             sv_setpvs(vs, "0");
167         }
168         else if ( items == 3 ) {
169             vs = sv_newmortal();
170             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
171         }
172
173         rv = new_version(vs);
174         if ( strnNE(classname,"version", len) ) /* inherited new() */
175             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
176
177         mPUSHs(rv);
178         PUTBACK;
179         return;
180     }
181 }
182
183 XS(XS_version_stringify)
184 {
185      dVAR;
186      dXSARGS;
187      if (items < 1)
188          croak_xs_usage(cv, "lobj, ...");
189      SP -= items;
190      {
191           SV *  lobj = ST(0);
192
193           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
194                lobj = SvRV(lobj);
195           }
196           else
197                Perl_croak(aTHX_ "lobj is not of type version");
198
199           mPUSHs(vstringify(lobj));
200
201           PUTBACK;
202           return;
203      }
204 }
205
206 XS(XS_version_numify)
207 {
208      dVAR;
209      dXSARGS;
210      if (items < 1)
211          croak_xs_usage(cv, "lobj, ...");
212      SP -= items;
213      {
214           SV *  lobj = ST(0);
215
216           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
217                lobj = SvRV(lobj);
218           }
219           else
220                Perl_croak(aTHX_ "lobj is not of type version");
221
222           mPUSHs(vnumify(lobj));
223
224           PUTBACK;
225           return;
226      }
227 }
228
229 XS(XS_version_normal)
230 {
231      dVAR;
232      dXSARGS;
233      if (items < 1)
234          croak_xs_usage(cv, "lobj, ...");
235      SP -= items;
236      {
237           SV *  lobj = ST(0);
238
239           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
240                lobj = SvRV(lobj);
241           }
242           else
243                Perl_croak(aTHX_ "lobj is not of type version");
244
245           mPUSHs(vnormal(lobj));
246
247           PUTBACK;
248           return;
249      }
250 }
251
252 XS(XS_version_vcmp)
253 {
254      dVAR;
255      dXSARGS;
256      if (items < 1)
257          croak_xs_usage(cv, "lobj, ...");
258      SP -= items;
259      {
260           SV *  lobj = ST(0);
261
262           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
263                lobj = SvRV(lobj);
264           }
265           else
266                Perl_croak(aTHX_ "lobj is not of type version");
267
268           {
269                SV       *rs;
270                SV       *rvs;
271                SV * robj = ST(1);
272                const IV  swap = (IV)SvIV(ST(2));
273
274                if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
275                {
276                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
277                     sv_2mortal(robj);
278                }
279                rvs = SvRV(robj);
280
281                if ( swap )
282                {
283                     rs = newSViv(vcmp(rvs,lobj));
284                }
285                else
286                {
287                     rs = newSViv(vcmp(lobj,rvs));
288                }
289
290                mPUSHs(rs);
291           }
292
293           PUTBACK;
294           return;
295      }
296 }
297
298 XS(XS_version_boolean)
299 {
300     dVAR;
301     dXSARGS;
302     if (items < 1)
303         croak_xs_usage(cv, "lobj, ...");
304     SP -= items;
305     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
306         SV * const lobj = SvRV(ST(0));
307         SV * const rs =
308             newSViv( vcmp(lobj,
309                           sv_2mortal(new_version(
310                                         sv_2mortal(newSVpvs("0"))
311                                     ))
312                          )
313                    );
314         mPUSHs(rs);
315         PUTBACK;
316         return;
317     }
318     else
319         Perl_croak(aTHX_ "lobj is not of type version");
320 }
321
322 XS(XS_version_noop)
323 {
324     dVAR;
325     dXSARGS;
326     if (items < 1)
327         croak_xs_usage(cv, "lobj, ...");
328     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
329         Perl_croak(aTHX_ "operation not supported with version object");
330     else
331         Perl_croak(aTHX_ "lobj is not of type version");
332 #ifndef HASATTRIBUTE_NORETURN
333     XSRETURN_EMPTY;
334 #endif
335 }
336
337 XS(XS_version_is_alpha)
338 {
339     dVAR;
340     dXSARGS;
341     if (items != 1)
342         croak_xs_usage(cv, "lobj");
343     SP -= items;
344     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
345         SV * const lobj = ST(0);
346         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
347             XSRETURN_YES;
348         else
349             XSRETURN_NO;
350         PUTBACK;
351         return;
352     }
353     else
354         Perl_croak(aTHX_ "lobj is not of type version");
355 }
356
357 XS(XS_version_qv)
358 {
359     dVAR;
360     dXSARGS;
361     PERL_UNUSED_ARG(cv);
362     SP -= items;
363     {
364         SV * ver = ST(0);
365         SV * rv;
366         STRLEN len = 0;
367         const char * classname = "";
368         U32 flags = 0;
369         if ( items == 2 ) {
370             SvGETMAGIC(ST(1));
371             if (SvOK(ST(1))) {
372                 ver = ST(1);
373             }
374             else {
375                 Perl_croak(aTHX_ "Invalid version format (version required)");
376             }
377             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
378                 const HV * stash = SvSTASH(SvRV(ST(0)));
379                 classname = HvNAME(stash);
380                 len       = HvNAMELEN(stash);
381                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
382             }
383             else {
384                classname = SvPV(ST(0), len);
385                 flags     = SvUTF8(ST(0));
386             }
387         }
388         if ( !SvVOK(ver) ) { /* not already a v-string */
389             rv = sv_newmortal();
390             sv_setsv(rv,ver); /* make a duplicate */
391             upg_version(rv, TRUE);
392         } else {
393             rv = sv_2mortal(new_version(ver));
394         }
395         if ( items == 2
396                 && strnNE(classname,"version", len) ) { /* inherited new() */
397             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
398         }
399         PUSHs(rv);
400     }
401     PUTBACK;
402     return;
403 }
404
405 XS(XS_version_is_qv)
406 {
407     dVAR;
408     dXSARGS;
409     if (items != 1)
410         croak_xs_usage(cv, "lobj");
411     SP -= items;
412     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
413         SV * const lobj = ST(0);
414         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
415             XSRETURN_YES;
416         else
417             XSRETURN_NO;
418         PUTBACK;
419         return;
420     }
421     else
422         Perl_croak(aTHX_ "lobj is not of type version");
423 }
424
425 #endif