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