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