This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test split on empty pattern with field count
[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 */
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
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
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 191VXS(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 271VXS(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 285VXS(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 298VXS(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 312VXS(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 347VXS(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 367VXS(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
379static
380void
381S_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
400VXS(version_is_alpha)
401{
402 S_version_check_key(aTHX_ cv, "alpha", 5);
403}
404
72f4d256 405VXS(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 461VXS(version_is_qv)
abc6d738 462{
05402f6b 463 S_version_check_key(aTHX_ cv, "qv", 2);
abc6d738
FC
464}
465
466#endif