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