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