Commit | Line | Data |
---|---|---|
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" | |
72f4d256 | 6 | # define VXSp(name) XS_##name |
05402f6b JP |
7 | /* VXSXSDP = XSUB Details Proto */ |
8 | # define VXSXSDP(x) x | |
b42aaea1 FC |
9 | #else |
10 | # define VXS_CLASS "version::vxs" | |
72f4d256 | 11 | # define VXSp(name) VXS_##name |
05402f6b JP |
12 | /* proto member is unused in version, it is used in CORE by non version xsubs */ |
13 | # define VXSXSDP(x) | |
b42aaea1 | 14 | #endif |
24120986 | 15 | #define VXS(name) XS(VXSp(name)); XS(VXSp(name)) |
b42aaea1 | 16 | |
9190f8ab JP |
17 | /* uses PUSHs, so SP must be at start, PUSHs sv on Perl stack, then returns from |
18 | xsub; this is a little more machine code/tailcall friendly than mPUSHs(foo); | |
19 | PUTBACK; return; */ | |
20 | ||
21 | #define VXS_RETURN_M_SV(sv) \ | |
22 | STMT_START { \ | |
23 | SV * sv_vtc = sv; \ | |
24 | PUSHs(sv_vtc); \ | |
25 | PUTBACK; \ | |
26 | sv_2mortal(sv_vtc); \ | |
27 | return; \ | |
28 | } STMT_END | |
29 | ||
30 | ||
abc6d738 | 31 | #ifdef VXS_XSUB_DETAILS |
b42aaea1 | 32 | # ifdef PERL_CORE |
05402f6b | 33 | {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)}, |
b42aaea1 | 34 | # endif |
05402f6b JP |
35 | {VXS_CLASS "::_VERSION", VXSp(universal_version), VXSXSDP(NULL)}, |
36 | {VXS_CLASS "::()", VXSp(version_noop), VXSXSDP(NULL)}, | |
37 | {VXS_CLASS "::new", VXSp(version_new), VXSXSDP(NULL)}, | |
38 | {VXS_CLASS "::parse", VXSp(version_new), VXSXSDP(NULL)}, | |
39 | {VXS_CLASS "::(\"\"", VXSp(version_stringify), VXSXSDP(NULL)}, | |
40 | {VXS_CLASS "::stringify", VXSp(version_stringify), VXSXSDP(NULL)}, | |
41 | {VXS_CLASS "::(0+", VXSp(version_numify), VXSXSDP(NULL)}, | |
42 | {VXS_CLASS "::numify", VXSp(version_numify), VXSXSDP(NULL)}, | |
43 | {VXS_CLASS "::normal", VXSp(version_normal), VXSXSDP(NULL)}, | |
44 | {VXS_CLASS "::(cmp", VXSp(version_vcmp), VXSXSDP(NULL)}, | |
45 | {VXS_CLASS "::(<=>", VXSp(version_vcmp), VXSXSDP(NULL)}, | |
b42aaea1 | 46 | # ifdef PERL_CORE |
05402f6b | 47 | {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)}, |
b42aaea1 | 48 | # else |
05402f6b | 49 | {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)}, |
b42aaea1 | 50 | # endif |
05402f6b JP |
51 | {VXS_CLASS "::(bool", VXSp(version_boolean), VXSXSDP(NULL)}, |
52 | {VXS_CLASS "::boolean", VXSp(version_boolean), VXSXSDP(NULL)}, | |
53 | {VXS_CLASS "::(+", VXSp(version_noop), VXSXSDP(NULL)}, | |
54 | {VXS_CLASS "::(-", VXSp(version_noop), VXSXSDP(NULL)}, | |
55 | {VXS_CLASS "::(*", VXSp(version_noop), VXSXSDP(NULL)}, | |
56 | {VXS_CLASS "::(/", VXSp(version_noop), VXSXSDP(NULL)}, | |
57 | {VXS_CLASS "::(+=", VXSp(version_noop), VXSXSDP(NULL)}, | |
58 | {VXS_CLASS "::(-=", VXSp(version_noop), VXSXSDP(NULL)}, | |
59 | {VXS_CLASS "::(*=", VXSp(version_noop), VXSXSDP(NULL)}, | |
60 | {VXS_CLASS "::(/=", VXSp(version_noop), VXSXSDP(NULL)}, | |
61 | {VXS_CLASS "::(abs", VXSp(version_noop), VXSXSDP(NULL)}, | |
62 | {VXS_CLASS "::(nomethod", VXSp(version_noop), VXSXSDP(NULL)}, | |
63 | {VXS_CLASS "::noop", VXSp(version_noop), VXSXSDP(NULL)}, | |
64 | {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), VXSXSDP(NULL)}, | |
65 | {VXS_CLASS "::qv", VXSp(version_qv), VXSXSDP(NULL)}, | |
66 | {VXS_CLASS "::declare", VXSp(version_qv), VXSXSDP(NULL)}, | |
67 | {VXS_CLASS "::is_qv", VXSp(version_is_qv), VXSXSDP(NULL)}, | |
abc6d738 FC |
68 | #else |
69 | ||
04df8d4d FC |
70 | #ifndef dVAR |
71 | # define dVAR | |
72 | #endif | |
73 | ||
0c96c511 FC |
74 | #ifdef HvNAME_HEK |
75 | typedef HEK HVNAME; | |
76 | # ifndef HEKf | |
77 | # define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg)))) | |
78 | # define HEKf SVf | |
79 | # endif | |
80 | #else | |
81 | typedef char HVNAME; | |
82 | # define HvNAME_HEK HvNAME_get | |
83 | # define HEKfARG(arg) arg | |
84 | # define HEKf "s" | |
85 | #endif | |
86 | ||
98079c48 | 87 | VXS(universal_version) |
abc6d738 FC |
88 | { |
89 | dVAR; | |
90 | dXSARGS; | |
91 | HV *pkg; | |
92 | GV **gvp; | |
93 | GV *gv; | |
94 | SV *sv; | |
95 | const char *undef; | |
96 | PERL_UNUSED_ARG(cv); | |
97 | ||
8372457d FC |
98 | if (items < 1) |
99 | Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)"); | |
100 | ||
0c96c511 FC |
101 | sv = ST(0); |
102 | ||
103 | if (SvROK(sv)) { | |
104 | sv = (SV*)SvRV(sv); | |
abc6d738 FC |
105 | if (!SvOBJECT(sv)) |
106 | Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); | |
107 | pkg = SvSTASH(sv); | |
108 | } | |
109 | else { | |
0c96c511 | 110 | pkg = gv_stashsv(sv, FALSE); |
abc6d738 FC |
111 | } |
112 | ||
0c96c511 | 113 | gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL; |
abc6d738 FC |
114 | |
115 | if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { | |
0c96c511 | 116 | sv = sv_mortalcopy(sv); |
05402f6b | 117 | if ( ! ISA_VERSION_OBJ(sv) ) |
0c96c511 | 118 | UPG_VERSION(sv, FALSE); |
abc6d738 FC |
119 | undef = NULL; |
120 | } | |
121 | else { | |
05402f6b | 122 | sv = &PL_sv_undef; |
abc6d738 FC |
123 | undef = "(undef)"; |
124 | } | |
125 | ||
126 | if (items > 1) { | |
127 | SV *req = ST(1); | |
128 | ||
129 | if (undef) { | |
130 | if (pkg) { | |
0c96c511 FC |
131 | const HVNAME* const name = HvNAME_HEK(pkg); |
132 | #if PERL_VERSION == 5 | |
133 | Perl_croak(aTHX_ "%s version %s required--this is only version ", | |
134 | name, SvPVx_nolen_const(req)); | |
135 | #else | |
abc6d738 FC |
136 | Perl_croak(aTHX_ |
137 | "%"HEKf" does not define $%"HEKf | |
138 | "::VERSION--version check failed", | |
139 | HEKfARG(name), HEKfARG(name)); | |
0c96c511 FC |
140 | #endif |
141 | } | |
142 | else { | |
143 | #if PERL_VERSION >= 8 | |
abc6d738 FC |
144 | Perl_croak(aTHX_ |
145 | "%"SVf" defines neither package nor VERSION--version check failed", | |
0c96c511 FC |
146 | (void*)(ST(0)) ); |
147 | #else | |
148 | Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", | |
149 | SvPVx_nolen_const(ST(0)), | |
150 | SvPVx_nolen_const(ST(0)) ); | |
151 | #endif | |
abc6d738 FC |
152 | } |
153 | } | |
154 | ||
05402f6b | 155 | if ( ! ISA_VERSION_OBJ(req) ) { |
abc6d738 | 156 | /* req may very well be R/O, so create a new object */ |
0c96c511 | 157 | req = sv_2mortal( NEW_VERSION(req) ); |
abc6d738 FC |
158 | } |
159 | ||
0c96c511 | 160 | if ( VCMP( req, sv ) > 0 ) { |
abc6d738 | 161 | if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { |
0c96c511 FC |
162 | req = VNORMAL(req); |
163 | sv = VNORMAL(sv); | |
164 | } | |
165 | else { | |
166 | req = VSTRINGIFY(req); | |
167 | sv = VSTRINGIFY(sv); | |
abc6d738 | 168 | } |
0c96c511 FC |
169 | Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" |
170 | "this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)), | |
171 | SVfARG(sv_2mortal(req)), | |
172 | SVfARG(sv_2mortal(sv))); | |
abc6d738 FC |
173 | } |
174 | } | |
175 | ||
0c96c511 | 176 | /* if the package's $VERSION is not undef, it is upgraded to be a version object */ |
05402f6b | 177 | if (ISA_VERSION_OBJ(sv)) { |
0c96c511 | 178 | ST(0) = sv_2mortal(VSTRINGIFY(sv)); |
abc6d738 FC |
179 | } else { |
180 | ST(0) = sv; | |
181 | } | |
182 | ||
183 | XSRETURN(1); | |
184 | } | |
185 | ||
72f4d256 | 186 | VXS(version_new) |
abc6d738 FC |
187 | { |
188 | dVAR; | |
189 | dXSARGS; | |
9190f8ab | 190 | SV *vs; |
e1c774b6 FC |
191 | SV *rv; |
192 | const char * classname = ""; | |
193 | STRLEN len; | |
194 | U32 flags = 0; | |
05402f6b | 195 | SV * svarg0 = NULL; |
39ced5ad KW |
196 | PERL_UNUSED_VAR(cv); |
197 | ||
abc6d738 | 198 | SP -= items; |
abc6d738 | 199 | |
9190f8ab JP |
200 | switch((U32)items) { |
201 | case 3: { | |
05402f6b | 202 | SV * svarg2; |
e1c774b6 | 203 | vs = sv_newmortal(); |
05402f6b | 204 | svarg2 = ST(2); |
e1c774b6 | 205 | #if PERL_VERSION == 5 |
05402f6b | 206 | sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2)); |
e1c774b6 | 207 | #else |
05402f6b | 208 | Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2)); |
e1c774b6 | 209 | #endif |
9190f8ab JP |
210 | break; |
211 | } | |
212 | case 2: | |
213 | vs = ST(1); | |
214 | /* Just in case this is something like a tied hash */ | |
215 | SvGETMAGIC(vs); | |
216 | if(SvOK(vs)) | |
217 | break; | |
218 | /* drop through */ | |
219 | case 1: | |
220 | /* no param or explicit undef */ | |
221 | /* create empty object */ | |
222 | vs = sv_newmortal(); | |
223 | sv_setpvs(vs,"undef"); | |
224 | break; | |
225 | default: | |
226 | case 0: | |
227 | Perl_croak_nocontext("Usage: version::new(class, version)"); | |
228 | break; | |
e1c774b6 | 229 | } |
9190f8ab | 230 | |
05402f6b JP |
231 | svarg0 = ST(0); |
232 | if ( sv_isobject(svarg0) ) { | |
e1c774b6 | 233 | /* get the class if called as an object method */ |
05402f6b | 234 | const HV * stash = SvSTASH(SvRV(svarg0)); |
e1c774b6 FC |
235 | classname = HvNAME_get(stash); |
236 | len = HvNAMELEN_get(stash); | |
237 | #ifdef HvNAMEUTF8 | |
238 | flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; | |
239 | #endif | |
240 | } | |
241 | else { | |
9190f8ab | 242 | classname = SvPV_nomg(svarg0, len); |
05402f6b | 243 | flags = SvUTF8(svarg0); |
abc6d738 | 244 | } |
e1c774b6 FC |
245 | |
246 | rv = NEW_VERSION(vs); | |
247 | if ( len != sizeof(VXS_CLASS)-1 | |
248 | || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */ | |
249 | #if PERL_VERSION == 5 | |
250 | sv_bless(rv, gv_stashpv((char *)classname, GV_ADD)); | |
251 | #else | |
252 | sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); | |
253 | #endif | |
254 | ||
9190f8ab | 255 | VXS_RETURN_M_SV(rv); |
abc6d738 FC |
256 | } |
257 | ||
5d450c46 FC |
258 | #define VTYPECHECK(var, val, varname) \ |
259 | STMT_START { \ | |
05402f6b JP |
260 | SV * sv_vtc = val; \ |
261 | if (ISA_VERSION_OBJ(sv_vtc)) { \ | |
262 | (var) = SvRV(sv_vtc); \ | |
5d450c46 FC |
263 | } \ |
264 | else \ | |
9190f8ab | 265 | Perl_croak_nocontext(varname " is not of type version"); \ |
5d450c46 FC |
266 | } STMT_END |
267 | ||
72f4d256 | 268 | VXS(version_stringify) |
abc6d738 FC |
269 | { |
270 | dVAR; | |
271 | dXSARGS; | |
272 | if (items < 1) | |
273 | croak_xs_usage(cv, "lobj, ..."); | |
274 | SP -= items; | |
275 | { | |
5d450c46 FC |
276 | SV * lobj; |
277 | VTYPECHECK(lobj, ST(0), "lobj"); | |
abc6d738 | 278 | |
9190f8ab | 279 | VXS_RETURN_M_SV(VSTRINGIFY(lobj)); |
abc6d738 FC |
280 | } |
281 | } | |
282 | ||
72f4d256 | 283 | VXS(version_numify) |
abc6d738 FC |
284 | { |
285 | dVAR; | |
286 | dXSARGS; | |
287 | if (items < 1) | |
288 | croak_xs_usage(cv, "lobj, ..."); | |
289 | SP -= items; | |
290 | { | |
5d450c46 FC |
291 | SV * lobj; |
292 | VTYPECHECK(lobj, ST(0), "lobj"); | |
9190f8ab | 293 | VXS_RETURN_M_SV(VNUMIFY(lobj)); |
abc6d738 FC |
294 | } |
295 | } | |
296 | ||
72f4d256 | 297 | VXS(version_normal) |
abc6d738 FC |
298 | { |
299 | dVAR; | |
300 | dXSARGS; | |
b47c4431 | 301 | if (items != 1) |
5d450c46 | 302 | croak_xs_usage(cv, "ver"); |
abc6d738 FC |
303 | SP -= items; |
304 | { | |
5d450c46 FC |
305 | SV * ver; |
306 | VTYPECHECK(ver, ST(0), "ver"); | |
abc6d738 | 307 | |
9190f8ab | 308 | VXS_RETURN_M_SV(VNORMAL(ver)); |
abc6d738 FC |
309 | } |
310 | } | |
311 | ||
72f4d256 | 312 | VXS(version_vcmp) |
abc6d738 FC |
313 | { |
314 | dVAR; | |
315 | dXSARGS; | |
316 | if (items < 1) | |
317 | croak_xs_usage(cv, "lobj, ..."); | |
318 | SP -= items; | |
319 | { | |
5d450c46 FC |
320 | SV * lobj; |
321 | VTYPECHECK(lobj, ST(0), "lobj"); | |
abc6d738 FC |
322 | { |
323 | SV *rs; | |
324 | SV *rvs; | |
325 | SV * robj = ST(1); | |
326 | const IV swap = (IV)SvIV(ST(2)); | |
327 | ||
05402f6b | 328 | if ( !ISA_VERSION_OBJ(robj) ) |
abc6d738 | 329 | { |
05402f6b | 330 | robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP))); |
abc6d738 FC |
331 | } |
332 | rvs = SvRV(robj); | |
333 | ||
334 | if ( swap ) | |
335 | { | |
5d450c46 | 336 | rs = newSViv(VCMP(rvs,lobj)); |
abc6d738 FC |
337 | } |
338 | else | |
339 | { | |
5d450c46 | 340 | rs = newSViv(VCMP(lobj,rvs)); |
abc6d738 FC |
341 | } |
342 | ||
9190f8ab | 343 | VXS_RETURN_M_SV(rs); |
abc6d738 | 344 | } |
abc6d738 FC |
345 | } |
346 | } | |
347 | ||
72f4d256 | 348 | VXS(version_boolean) |
abc6d738 FC |
349 | { |
350 | dVAR; | |
351 | dXSARGS; | |
5d450c46 | 352 | SV *lobj; |
abc6d738 FC |
353 | if (items < 1) |
354 | croak_xs_usage(cv, "lobj, ..."); | |
355 | SP -= items; | |
5d450c46 FC |
356 | VTYPECHECK(lobj, ST(0), "lobj"); |
357 | { | |
abc6d738 | 358 | SV * const rs = |
5d450c46 FC |
359 | newSViv( VCMP(lobj, |
360 | sv_2mortal(NEW_VERSION( | |
abc6d738 FC |
361 | sv_2mortal(newSVpvs("0")) |
362 | )) | |
363 | ) | |
364 | ); | |
9190f8ab | 365 | VXS_RETURN_M_SV(rs); |
abc6d738 | 366 | } |
abc6d738 FC |
367 | } |
368 | ||
72f4d256 | 369 | VXS(version_noop) |
abc6d738 FC |
370 | { |
371 | dVAR; | |
372 | dXSARGS; | |
373 | if (items < 1) | |
374 | croak_xs_usage(cv, "lobj, ..."); | |
05402f6b | 375 | if (ISA_VERSION_OBJ(ST(0))) |
abc6d738 FC |
376 | Perl_croak(aTHX_ "operation not supported with version object"); |
377 | else | |
378 | Perl_croak(aTHX_ "lobj is not of type version"); | |
abc6d738 | 379 | XSRETURN_EMPTY; |
abc6d738 FC |
380 | } |
381 | ||
05402f6b JP |
382 | static |
383 | void | |
384 | S_version_check_key(pTHX_ CV * cv, const char * key, int keylen) | |
abc6d738 FC |
385 | { |
386 | dVAR; | |
387 | dXSARGS; | |
388 | if (items != 1) | |
389 | croak_xs_usage(cv, "lobj"); | |
5d450c46 | 390 | { |
05402f6b JP |
391 | SV *lobj = POPs; |
392 | SV *ret; | |
393 | VTYPECHECK(lobj, lobj, "lobj"); | |
394 | if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) ) | |
395 | ret = &PL_sv_yes; | |
abc6d738 | 396 | else |
05402f6b JP |
397 | ret = &PL_sv_no; |
398 | PUSHs(ret); | |
abc6d738 FC |
399 | PUTBACK; |
400 | return; | |
401 | } | |
abc6d738 FC |
402 | } |
403 | ||
05402f6b JP |
404 | VXS(version_is_alpha) |
405 | { | |
406 | S_version_check_key(aTHX_ cv, "alpha", 5); | |
407 | } | |
408 | ||
72f4d256 | 409 | VXS(version_qv) |
abc6d738 FC |
410 | { |
411 | dVAR; | |
412 | dXSARGS; | |
413 | PERL_UNUSED_ARG(cv); | |
414 | SP -= items; | |
415 | { | |
416 | SV * ver = ST(0); | |
05402f6b | 417 | SV * sv0 = ver; |
abc6d738 FC |
418 | SV * rv; |
419 | STRLEN len = 0; | |
420 | const char * classname = ""; | |
421 | U32 flags = 0; | |
422 | if ( items == 2 ) { | |
05402f6b JP |
423 | SV * sv1 = ST(1); |
424 | SvGETMAGIC(sv1); | |
425 | if (SvOK(sv1)) { | |
426 | ver = sv1; | |
abc6d738 FC |
427 | } |
428 | else { | |
429 | Perl_croak(aTHX_ "Invalid version format (version required)"); | |
430 | } | |
05402f6b JP |
431 | if ( sv_isobject(sv0) ) { /* class called as an object method */ |
432 | const HV * stash = SvSTASH(SvRV(sv0)); | |
5d450c46 FC |
433 | classname = HvNAME_get(stash); |
434 | len = HvNAMELEN_get(stash); | |
435 | #ifdef HvNAMEUTF8 | |
abc6d738 | 436 | flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; |
5d450c46 | 437 | #endif |
abc6d738 FC |
438 | } |
439 | else { | |
05402f6b JP |
440 | classname = SvPV(sv0, len); |
441 | flags = SvUTF8(sv0); | |
abc6d738 | 442 | } |
5d450c46 | 443 | } |
abc6d738 FC |
444 | if ( !SvVOK(ver) ) { /* not already a v-string */ |
445 | rv = sv_newmortal(); | |
95a23f5d | 446 | SvSetSV_nosteal(rv,ver); /* make a duplicate */ |
5d450c46 | 447 | UPG_VERSION(rv, TRUE); |
abc6d738 | 448 | } else { |
5d450c46 | 449 | rv = sv_2mortal(NEW_VERSION(ver)); |
abc6d738 | 450 | } |
8a3edca7 | 451 | if ( items == 2 && (len != 7 |
5d450c46 FC |
452 | || strcmp(classname,"version")) ) { /* inherited new() */ |
453 | #if PERL_VERSION == 5 | |
454 | sv_bless(rv, gv_stashpv((char *)classname, GV_ADD)); | |
455 | #else | |
abc6d738 | 456 | sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); |
5d450c46 | 457 | #endif |
abc6d738 FC |
458 | } |
459 | PUSHs(rv); | |
460 | } | |
461 | PUTBACK; | |
462 | return; | |
463 | } | |
464 | ||
05402f6b | 465 | |
72f4d256 | 466 | VXS(version_is_qv) |
abc6d738 | 467 | { |
05402f6b | 468 | S_version_check_key(aTHX_ cv, "qv", 2); |
abc6d738 FC |
469 | } |
470 | ||
471 | #endif |