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 | 7 | /* VXSXSDP = XSUB Details Proto */ |
d88d17cb | 8 | # define VXSXSDP(x) x, 0 |
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 | 140 | Perl_croak(aTHX_ |
d3a5b29c | 141 | "%" HEKf " does not define $%" HEKf |
abc6d738 FC |
142 | "::VERSION--version check failed", |
143 | HEKfARG(name), HEKfARG(name)); | |
0c96c511 FC |
144 | #endif |
145 | } | |
146 | else { | |
147 | #if PERL_VERSION >= 8 | |
abc6d738 | 148 | Perl_croak(aTHX_ |
dddb2275 JP |
149 | "%" SVf " defines neither package nor VERSION--" |
150 | "version check failed", | |
0c96c511 FC |
151 | (void*)(ST(0)) ); |
152 | #else | |
153 | Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", | |
154 | SvPVx_nolen_const(ST(0)), | |
155 | SvPVx_nolen_const(ST(0)) ); | |
156 | #endif | |
abc6d738 FC |
157 | } |
158 | } | |
159 | ||
05402f6b | 160 | if ( ! ISA_VERSION_OBJ(req) ) { |
abc6d738 | 161 | /* req may very well be R/O, so create a new object */ |
0c96c511 | 162 | req = sv_2mortal( NEW_VERSION(req) ); |
abc6d738 FC |
163 | } |
164 | ||
0c96c511 | 165 | if ( VCMP( req, sv ) > 0 ) { |
dddb2275 | 166 | if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { |
0c96c511 FC |
167 | req = VNORMAL(req); |
168 | sv = VNORMAL(sv); | |
169 | } | |
170 | else { | |
171 | req = VSTRINGIFY(req); | |
172 | sv = VSTRINGIFY(sv); | |
abc6d738 | 173 | } |
dddb2275 JP |
174 | Perl_croak(aTHX_ "%" HEKf " version %" SVf " required--" |
175 | "this is only version %" SVf, HEKfARG(HvNAME_HEK(pkg)), | |
0c96c511 FC |
176 | SVfARG(sv_2mortal(req)), |
177 | SVfARG(sv_2mortal(sv))); | |
abc6d738 FC |
178 | } |
179 | } | |
180 | ||
0c96c511 | 181 | /* if the package's $VERSION is not undef, it is upgraded to be a version object */ |
05402f6b | 182 | if (ISA_VERSION_OBJ(sv)) { |
0c96c511 | 183 | ST(0) = sv_2mortal(VSTRINGIFY(sv)); |
abc6d738 FC |
184 | } else { |
185 | ST(0) = sv; | |
186 | } | |
187 | ||
188 | XSRETURN(1); | |
189 | } | |
190 | ||
72f4d256 | 191 | VXS(version_new) |
abc6d738 | 192 | { |
abc6d738 | 193 | dXSARGS; |
9190f8ab | 194 | SV *vs; |
e1c774b6 FC |
195 | SV *rv; |
196 | const char * classname = ""; | |
197 | STRLEN len; | |
198 | U32 flags = 0; | |
05402f6b | 199 | SV * svarg0 = NULL; |
39ced5ad KW |
200 | PERL_UNUSED_VAR(cv); |
201 | ||
abc6d738 | 202 | SP -= items; |
abc6d738 | 203 | |
9190f8ab JP |
204 | switch((U32)items) { |
205 | case 3: { | |
05402f6b | 206 | SV * svarg2; |
e1c774b6 | 207 | vs = sv_newmortal(); |
05402f6b | 208 | svarg2 = ST(2); |
e1c774b6 | 209 | #if PERL_VERSION == 5 |
05402f6b | 210 | sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2)); |
e1c774b6 | 211 | #else |
05402f6b | 212 | Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2)); |
e1c774b6 | 213 | #endif |
9190f8ab JP |
214 | break; |
215 | } | |
216 | case 2: | |
217 | vs = ST(1); | |
218 | /* Just in case this is something like a tied hash */ | |
219 | SvGETMAGIC(vs); | |
220 | if(SvOK(vs)) | |
221 | break; | |
2165bd23 | 222 | /* fall through */ |
9190f8ab JP |
223 | case 1: |
224 | /* no param or explicit undef */ | |
225 | /* create empty object */ | |
226 | vs = sv_newmortal(); | |
227 | sv_setpvs(vs,"undef"); | |
228 | break; | |
229 | default: | |
230 | case 0: | |
231 | Perl_croak_nocontext("Usage: version::new(class, version)"); | |
e1c774b6 | 232 | } |
9190f8ab | 233 | |
05402f6b JP |
234 | svarg0 = ST(0); |
235 | if ( sv_isobject(svarg0) ) { | |
e1c774b6 | 236 | /* get the class if called as an object method */ |
05402f6b | 237 | const HV * stash = SvSTASH(SvRV(svarg0)); |
e1c774b6 FC |
238 | classname = HvNAME_get(stash); |
239 | len = HvNAMELEN_get(stash); | |
240 | #ifdef HvNAMEUTF8 | |
241 | flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; | |
242 | #endif | |
243 | } | |
244 | else { | |
9190f8ab | 245 | classname = SvPV_nomg(svarg0, len); |
05402f6b | 246 | flags = SvUTF8(svarg0); |
abc6d738 | 247 | } |
e1c774b6 FC |
248 | |
249 | rv = NEW_VERSION(vs); | |
250 | if ( len != sizeof(VXS_CLASS)-1 | |
251 | || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */ | |
252 | #if PERL_VERSION == 5 | |
253 | sv_bless(rv, gv_stashpv((char *)classname, GV_ADD)); | |
254 | #else | |
255 | sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); | |
256 | #endif | |
257 | ||
9190f8ab | 258 | VXS_RETURN_M_SV(rv); |
abc6d738 FC |
259 | } |
260 | ||
5d450c46 FC |
261 | #define VTYPECHECK(var, val, varname) \ |
262 | STMT_START { \ | |
05402f6b JP |
263 | SV * sv_vtc = val; \ |
264 | if (ISA_VERSION_OBJ(sv_vtc)) { \ | |
265 | (var) = SvRV(sv_vtc); \ | |
5d450c46 FC |
266 | } \ |
267 | else \ | |
9190f8ab | 268 | Perl_croak_nocontext(varname " is not of type version"); \ |
5d450c46 FC |
269 | } STMT_END |
270 | ||
72f4d256 | 271 | VXS(version_stringify) |
abc6d738 | 272 | { |
abc6d738 FC |
273 | dXSARGS; |
274 | if (items < 1) | |
275 | croak_xs_usage(cv, "lobj, ..."); | |
276 | SP -= items; | |
277 | { | |
5d450c46 FC |
278 | SV * lobj; |
279 | VTYPECHECK(lobj, ST(0), "lobj"); | |
abc6d738 | 280 | |
9190f8ab | 281 | VXS_RETURN_M_SV(VSTRINGIFY(lobj)); |
abc6d738 FC |
282 | } |
283 | } | |
284 | ||
72f4d256 | 285 | VXS(version_numify) |
abc6d738 | 286 | { |
abc6d738 FC |
287 | dXSARGS; |
288 | if (items < 1) | |
289 | croak_xs_usage(cv, "lobj, ..."); | |
290 | SP -= items; | |
291 | { | |
5d450c46 FC |
292 | SV * lobj; |
293 | VTYPECHECK(lobj, ST(0), "lobj"); | |
9190f8ab | 294 | VXS_RETURN_M_SV(VNUMIFY(lobj)); |
abc6d738 FC |
295 | } |
296 | } | |
297 | ||
72f4d256 | 298 | VXS(version_normal) |
abc6d738 | 299 | { |
abc6d738 | 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 | 313 | { |
abc6d738 FC |
314 | dXSARGS; |
315 | if (items < 1) | |
316 | croak_xs_usage(cv, "lobj, ..."); | |
317 | SP -= items; | |
318 | { | |
5d450c46 FC |
319 | SV * lobj; |
320 | VTYPECHECK(lobj, ST(0), "lobj"); | |
abc6d738 FC |
321 | { |
322 | SV *rs; | |
323 | SV *rvs; | |
324 | SV * robj = ST(1); | |
325 | const IV swap = (IV)SvIV(ST(2)); | |
326 | ||
05402f6b | 327 | if ( !ISA_VERSION_OBJ(robj) ) |
abc6d738 | 328 | { |
05402f6b | 329 | robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP))); |
abc6d738 FC |
330 | } |
331 | rvs = SvRV(robj); | |
332 | ||
333 | if ( swap ) | |
334 | { | |
5d450c46 | 335 | rs = newSViv(VCMP(rvs,lobj)); |
abc6d738 FC |
336 | } |
337 | else | |
338 | { | |
5d450c46 | 339 | rs = newSViv(VCMP(lobj,rvs)); |
abc6d738 FC |
340 | } |
341 | ||
9190f8ab | 342 | VXS_RETURN_M_SV(rs); |
abc6d738 | 343 | } |
abc6d738 FC |
344 | } |
345 | } | |
346 | ||
72f4d256 | 347 | VXS(version_boolean) |
abc6d738 | 348 | { |
abc6d738 | 349 | dXSARGS; |
5d450c46 | 350 | SV *lobj; |
abc6d738 FC |
351 | if (items < 1) |
352 | croak_xs_usage(cv, "lobj, ..."); | |
353 | SP -= items; | |
5d450c46 FC |
354 | VTYPECHECK(lobj, ST(0), "lobj"); |
355 | { | |
abc6d738 | 356 | SV * const rs = |
5d450c46 FC |
357 | newSViv( VCMP(lobj, |
358 | sv_2mortal(NEW_VERSION( | |
abc6d738 FC |
359 | sv_2mortal(newSVpvs("0")) |
360 | )) | |
361 | ) | |
362 | ); | |
9190f8ab | 363 | VXS_RETURN_M_SV(rs); |
abc6d738 | 364 | } |
abc6d738 FC |
365 | } |
366 | ||
72f4d256 | 367 | VXS(version_noop) |
abc6d738 | 368 | { |
abc6d738 FC |
369 | dXSARGS; |
370 | if (items < 1) | |
371 | croak_xs_usage(cv, "lobj, ..."); | |
05402f6b | 372 | if (ISA_VERSION_OBJ(ST(0))) |
abc6d738 FC |
373 | Perl_croak(aTHX_ "operation not supported with version object"); |
374 | else | |
375 | Perl_croak(aTHX_ "lobj is not of type version"); | |
abc6d738 | 376 | XSRETURN_EMPTY; |
abc6d738 FC |
377 | } |
378 | ||
05402f6b JP |
379 | static |
380 | void | |
381 | S_version_check_key(pTHX_ CV * cv, const char * key, int keylen) | |
abc6d738 | 382 | { |
abc6d738 FC |
383 | dXSARGS; |
384 | if (items != 1) | |
385 | croak_xs_usage(cv, "lobj"); | |
5d450c46 | 386 | { |
05402f6b JP |
387 | SV *lobj = POPs; |
388 | SV *ret; | |
389 | VTYPECHECK(lobj, lobj, "lobj"); | |
390 | if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) ) | |
391 | ret = &PL_sv_yes; | |
abc6d738 | 392 | else |
05402f6b JP |
393 | ret = &PL_sv_no; |
394 | PUSHs(ret); | |
abc6d738 FC |
395 | PUTBACK; |
396 | return; | |
397 | } | |
abc6d738 FC |
398 | } |
399 | ||
05402f6b JP |
400 | VXS(version_is_alpha) |
401 | { | |
402 | S_version_check_key(aTHX_ cv, "alpha", 5); | |
403 | } | |
404 | ||
72f4d256 | 405 | VXS(version_qv) |
abc6d738 | 406 | { |
abc6d738 FC |
407 | dXSARGS; |
408 | PERL_UNUSED_ARG(cv); | |
409 | SP -= items; | |
410 | { | |
411 | SV * ver = ST(0); | |
05402f6b | 412 | SV * sv0 = ver; |
abc6d738 FC |
413 | SV * rv; |
414 | STRLEN len = 0; | |
415 | const char * classname = ""; | |
416 | U32 flags = 0; | |
417 | if ( items == 2 ) { | |
05402f6b JP |
418 | SV * sv1 = ST(1); |
419 | SvGETMAGIC(sv1); | |
420 | if (SvOK(sv1)) { | |
421 | ver = sv1; | |
abc6d738 FC |
422 | } |
423 | else { | |
424 | Perl_croak(aTHX_ "Invalid version format (version required)"); | |
425 | } | |
05402f6b JP |
426 | if ( sv_isobject(sv0) ) { /* class called as an object method */ |
427 | const HV * stash = SvSTASH(SvRV(sv0)); | |
5d450c46 FC |
428 | classname = HvNAME_get(stash); |
429 | len = HvNAMELEN_get(stash); | |
430 | #ifdef HvNAMEUTF8 | |
abc6d738 | 431 | flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; |
5d450c46 | 432 | #endif |
abc6d738 FC |
433 | } |
434 | else { | |
05402f6b JP |
435 | classname = SvPV(sv0, len); |
436 | flags = SvUTF8(sv0); | |
abc6d738 | 437 | } |
5d450c46 | 438 | } |
abc6d738 FC |
439 | if ( !SvVOK(ver) ) { /* not already a v-string */ |
440 | rv = sv_newmortal(); | |
95a23f5d | 441 | SvSetSV_nosteal(rv,ver); /* make a duplicate */ |
5d450c46 | 442 | UPG_VERSION(rv, TRUE); |
abc6d738 | 443 | } else { |
5d450c46 | 444 | rv = sv_2mortal(NEW_VERSION(ver)); |
abc6d738 | 445 | } |
8a3edca7 | 446 | if ( items == 2 && (len != 7 |
5d450c46 FC |
447 | || strcmp(classname,"version")) ) { /* inherited new() */ |
448 | #if PERL_VERSION == 5 | |
449 | sv_bless(rv, gv_stashpv((char *)classname, GV_ADD)); | |
450 | #else | |
abc6d738 | 451 | sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); |
5d450c46 | 452 | #endif |
abc6d738 FC |
453 | } |
454 | PUSHs(rv); | |
455 | } | |
456 | PUTBACK; | |
457 | return; | |
458 | } | |
459 | ||
05402f6b | 460 | |
72f4d256 | 461 | VXS(version_is_qv) |
abc6d738 | 462 | { |
05402f6b | 463 | S_version_check_key(aTHX_ cv, "qv", 2); |
abc6d738 FC |
464 | } |
465 | ||
466 | #endif |