This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
msgrcv: properly downgrade the receive buffer
[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 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
80typedef HEK HVNAME;
81# ifndef HEKf
82# define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg))))
83# define HEKf SVf
84# endif
85#else
86typedef char HVNAME;
87# define HvNAME_HEK HvNAME_get
88# define HEKfARG(arg) arg
89# define HEKf "s"
90#endif
91
98079c48 92VXS(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 186VXS(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 258VXS(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 272VXS(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 285VXS(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 299VXS(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 334VXS(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 354VXS(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
366static
367void
368S_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
387VXS(version_is_alpha)
388{
389 S_version_check_key(aTHX_ cv, "alpha", 5);
390}
391
72f4d256 392VXS(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 444VXS(version_is_qv)
abc6d738 445{
05402f6b 446 S_version_check_key(aTHX_ cv, "qv", 2);
abc6d738
FC
447}
448
449#endif