add changelog for if.pm
[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)); XS(VXSp(name))
16
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
31 #ifdef VXS_XSUB_DETAILS
32 #  ifdef PERL_CORE
33     {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)},
34 #  endif
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)},
46 #  ifdef PERL_CORE
47     {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)},
48 #  else
49     {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)},
50 #  endif
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)},
68 #else
69
70 #ifndef dVAR
71 #  define dVAR
72 #endif
73
74 #ifdef HvNAME_HEK
75 typedef HEK HVNAME;
76 #  ifndef HEKf
77 #    define HEKfARG(arg)        ((void*)(sv_2mortal(newSVhek(arg))))
78 #    define HEKf                SVf
79 #  endif
80 #else
81 typedef char HVNAME;
82 #  define HvNAME_HEK    HvNAME_get
83 #  define HEKfARG(arg)  arg
84 #  define HEKf          "s"
85 #endif
86
87 VXS(universal_version)
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
98     if (items < 1)
99        Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
100
101     sv = ST(0);
102
103     if (SvROK(sv)) {
104         sv = (SV*)SvRV(sv);
105         if (!SvOBJECT(sv))
106             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
107         pkg = SvSTASH(sv);
108     }
109     else {
110         pkg = gv_stashsv(sv, FALSE);
111     }
112
113     gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
114
115     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
116         sv = sv_mortalcopy(sv);
117         if ( ! ISA_VERSION_OBJ(sv) )
118             UPG_VERSION(sv, FALSE);
119         undef = NULL;
120     }
121     else {
122         sv = &PL_sv_undef;
123         undef = "(undef)";
124     }
125
126     if (items > 1) {
127         SV *req = ST(1);
128
129         if (undef) {
130             if (pkg) {
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
136                 Perl_croak(aTHX_
137                            "%"HEKf" does not define $%"HEKf
138                            "::VERSION--version check failed",
139                            HEKfARG(name), HEKfARG(name));
140 #endif
141             }
142             else {
143 #if PERL_VERSION >= 8
144                 Perl_croak(aTHX_
145                              "%"SVf" defines neither package nor VERSION--version check failed",
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
152             }
153         }
154
155         if ( ! ISA_VERSION_OBJ(req) ) {
156             /* req may very well be R/O, so create a new object */
157             req = sv_2mortal( NEW_VERSION(req) );
158         }
159
160         if ( VCMP( req, sv ) > 0 ) {
161             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
162                 req = VNORMAL(req);
163                 sv  = VNORMAL(sv);
164             }
165             else {
166                 req = VSTRINGIFY(req);
167                 sv  = VSTRINGIFY(sv);
168             }
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)));
173         }
174     }
175
176     /* if the package's $VERSION is not undef, it is upgraded to be a version object */
177     if (ISA_VERSION_OBJ(sv)) {
178         ST(0) = sv_2mortal(VSTRINGIFY(sv));
179     } else {
180         ST(0) = sv;
181     }
182
183     XSRETURN(1);
184 }
185
186 VXS(version_new)
187 {
188     dVAR;
189     dXSARGS;
190     SV *vs;
191     SV *rv;
192     const char * classname = "";
193     STRLEN len;
194     U32 flags = 0;
195     SV * svarg0 = NULL;
196     PERL_UNUSED_VAR(cv);
197
198     SP -= items;
199
200     switch((U32)items) {
201     case 3: {
202         SV * svarg2;
203         vs = sv_newmortal();
204         svarg2 = ST(2);
205 #if PERL_VERSION == 5
206         sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2));
207 #else
208         Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
209 #endif
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;
229     }
230
231     svarg0 = ST(0);
232     if ( sv_isobject(svarg0) ) {
233         /* get the class if called as an object method */
234         const HV * stash = SvSTASH(SvRV(svarg0));
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 {
242         classname = SvPV_nomg(svarg0, len);
243         flags     = SvUTF8(svarg0);
244     }
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
255     VXS_RETURN_M_SV(rv);
256 }
257
258 #define VTYPECHECK(var, val, varname) \
259     STMT_START {                                                        \
260         SV * sv_vtc = val;                                              \
261         if (ISA_VERSION_OBJ(sv_vtc)) {                          \
262             (var) = SvRV(sv_vtc);                                               \
263         }                                                               \
264         else                                                            \
265             Perl_croak_nocontext(varname " is not of type version");    \
266     } STMT_END
267
268 VXS(version_stringify)
269 {
270      dVAR;
271      dXSARGS;
272      if (items < 1)
273          croak_xs_usage(cv, "lobj, ...");
274      SP -= items;
275      {
276           SV *  lobj;
277           VTYPECHECK(lobj, ST(0), "lobj");
278
279           VXS_RETURN_M_SV(VSTRINGIFY(lobj));
280      }
281 }
282
283 VXS(version_numify)
284 {
285      dVAR;
286      dXSARGS;
287      if (items < 1)
288          croak_xs_usage(cv, "lobj, ...");
289      SP -= items;
290      {
291           SV *  lobj;
292           VTYPECHECK(lobj, ST(0), "lobj");
293           VXS_RETURN_M_SV(VNUMIFY(lobj));
294      }
295 }
296
297 VXS(version_normal)
298 {
299      dVAR;
300      dXSARGS;
301      if (items != 1)
302          croak_xs_usage(cv, "ver");
303      SP -= items;
304      {
305           SV *  ver;
306           VTYPECHECK(ver, ST(0), "ver");
307
308           VXS_RETURN_M_SV(VNORMAL(ver));
309      }
310 }
311
312 VXS(version_vcmp)
313 {
314      dVAR;
315      dXSARGS;
316      if (items < 1)
317          croak_xs_usage(cv, "lobj, ...");
318      SP -= items;
319      {
320           SV *  lobj;
321           VTYPECHECK(lobj, ST(0), "lobj");
322           {
323                SV       *rs;
324                SV       *rvs;
325                SV * robj = ST(1);
326                const IV  swap = (IV)SvIV(ST(2));
327
328                if ( !ISA_VERSION_OBJ(robj) )
329                {
330                     robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)));
331                }
332                rvs = SvRV(robj);
333
334                if ( swap )
335                {
336                     rs = newSViv(VCMP(rvs,lobj));
337                }
338                else
339                {
340                     rs = newSViv(VCMP(lobj,rvs));
341                }
342
343                VXS_RETURN_M_SV(rs);
344           }
345      }
346 }
347
348 VXS(version_boolean)
349 {
350     dVAR;
351     dXSARGS;
352     SV *lobj;
353     if (items < 1)
354         croak_xs_usage(cv, "lobj, ...");
355     SP -= items;
356     VTYPECHECK(lobj, ST(0), "lobj");
357     {
358         SV * const rs =
359             newSViv( VCMP(lobj,
360                           sv_2mortal(NEW_VERSION(
361                                         sv_2mortal(newSVpvs("0"))
362                                     ))
363                          )
364                    );
365         VXS_RETURN_M_SV(rs);
366     }
367 }
368
369 VXS(version_noop)
370 {
371     dVAR;
372     dXSARGS;
373     if (items < 1)
374         croak_xs_usage(cv, "lobj, ...");
375     if (ISA_VERSION_OBJ(ST(0)))
376         Perl_croak(aTHX_ "operation not supported with version object");
377     else
378         Perl_croak(aTHX_ "lobj is not of type version");
379     XSRETURN_EMPTY;
380 }
381
382 static
383 void
384 S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
385 {
386     dVAR;
387     dXSARGS;
388     if (items != 1)
389         croak_xs_usage(cv, "lobj");
390     {
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;
396         else
397             ret = &PL_sv_no;
398         PUSHs(ret);
399         PUTBACK;
400         return;
401     }
402 }
403
404 VXS(version_is_alpha)
405 {
406     S_version_check_key(aTHX_ cv, "alpha", 5);
407 }
408
409 VXS(version_qv)
410 {
411     dVAR;
412     dXSARGS;
413     PERL_UNUSED_ARG(cv);
414     SP -= items;
415     {
416         SV * ver = ST(0);
417         SV * sv0 = ver;
418         SV * rv;
419         STRLEN len = 0;
420         const char * classname = "";
421         U32 flags = 0;
422         if ( items == 2 ) {
423             SV * sv1 = ST(1);
424             SvGETMAGIC(sv1);
425             if (SvOK(sv1)) {
426                 ver = sv1;
427             }
428             else {
429                 Perl_croak(aTHX_ "Invalid version format (version required)");
430             }
431             if ( sv_isobject(sv0) ) { /* class called as an object method */
432                 const HV * stash = SvSTASH(SvRV(sv0));
433                 classname = HvNAME_get(stash);
434                 len       = HvNAMELEN_get(stash);
435 #ifdef HvNAMEUTF8
436                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
437 #endif
438             }
439             else {
440                classname = SvPV(sv0, len);
441                 flags     = SvUTF8(sv0);
442             }
443         }
444         if ( !SvVOK(ver) ) { /* not already a v-string */
445             rv = sv_newmortal();
446             SvSetSV_nosteal(rv,ver); /* make a duplicate */
447             UPG_VERSION(rv, TRUE);
448         } else {
449             rv = sv_2mortal(NEW_VERSION(ver));
450         }
451         if ( items == 2 && (len != 7
452                 || strcmp(classname,"version")) ) { /* inherited new() */
453 #if PERL_VERSION == 5
454             sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
455 #else
456             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
457 #endif
458         }
459         PUSHs(rv);
460     }
461     PUTBACK;
462     return;
463 }
464
465
466 VXS(version_is_qv)
467 {
468     S_version_check_key(aTHX_ cv, "qv", 2);
469 }
470
471 #endif