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