This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
universal.c: include vutil.h
[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
04df8d4d
FC
50#ifndef dVAR
51# define dVAR
52#endif
53
abc6d738
FC
54XS(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
8372457d
FC
65 if (items < 1)
66 Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
67
abc6d738
FC
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
142XS(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
190XS(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
213XS(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
236XS(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
259XS(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
305XS(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
329XS(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
344XS(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
364XS(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
412XS(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