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