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