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