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