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
CommitLineData
abc6d738
FC
1/* This file is part of the "version" CPAN distribution. Please avoid
2 editing it in the perl core. */
3
b42aaea1
FC
4#ifdef PERL_CORE
5# define VXS_CLASS "version"
6#else
7# define VXS_CLASS "version::vxs"
8#endif
9
abc6d738 10#ifdef VXS_XSUB_DETAILS
b42aaea1 11# ifdef PERL_CORE
abc6d738 12 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
b42aaea1
FC
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},
abc6d738
FC
48#else
49
50XS(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
135XS(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
183XS(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
206XS(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
229XS(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
252XS(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
298XS(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
322XS(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
337XS(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
357XS(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
405XS(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