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
CommitLineData
abc6d738
FC
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
36XS(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
121XS(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
169XS(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
192XS(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
215XS(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
238XS(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
284XS(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
308XS(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
323XS(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
343XS(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
391XS(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