This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
update the links to freenode
[perl5.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, 0
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
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))
21
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
36 #ifdef VXS_XSUB_DETAILS
37 #  ifdef PERL_CORE
38     {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)},
39 #  endif
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)},
51 #  ifdef PERL_CORE
52     {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)},
53 #  else
54     {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)},
55 #  endif
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)},
73 #else
74
75 #ifndef dVAR
76 #  define dVAR
77 #endif
78
79 #ifdef HvNAME_HEK
80 typedef HEK HVNAME;
81 #  ifndef HEKf
82 #    define HEKfARG(arg)        ((void*)(sv_2mortal(newSVhek(arg))))
83 #    define HEKf                SVf
84 #  endif
85 #else
86 typedef char HVNAME;
87 #  define HvNAME_HEK    HvNAME_get
88 #  define HEKfARG(arg)  arg
89 #  define HEKf          "s"
90 #endif
91
92 VXS(universal_version)
93 {
94     dXSARGS;
95     HV *pkg;
96     GV **gvp;
97     GV *gv;
98     SV *sv;
99     const char *undef;
100     PERL_UNUSED_ARG(cv);
101
102     if (items < 1)
103        Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
104
105     sv = ST(0);
106
107     if (SvROK(sv)) {
108         sv = (SV*)SvRV(sv);
109         if (!SvOBJECT(sv))
110             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
111         pkg = SvSTASH(sv);
112     }
113     else {
114         pkg = gv_stashsv(sv, FALSE);
115     }
116
117     gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
118
119     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
120         sv = sv_mortalcopy(sv);
121         if ( ! ISA_VERSION_OBJ(sv) )
122             UPG_VERSION(sv, FALSE);
123         undef = NULL;
124     }
125     else {
126         sv = &PL_sv_undef;
127         undef = "(undef)";
128     }
129
130     if (items > 1) {
131         SV *req = ST(1);
132
133         if (undef) {
134             if (pkg) {
135                 const HVNAME* const name = HvNAME_HEK(pkg);
136                 Perl_croak(aTHX_
137                            "%" HEKf " does not define $%" HEKf
138                            "::VERSION--version check failed",
139                            HEKfARG(name), HEKfARG(name));
140             }
141             else {
142 #if PERL_VERSION_GE(5,8,0)
143                 Perl_croak(aTHX_
144                              "%" SVf " defines neither package nor VERSION--"
145                              "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     dXSARGS;
189     SV *vs;
190     SV *rv;
191     const char * classname = "";
192     STRLEN len;
193     U32 flags = 0;
194     SV * svarg0 = NULL;
195     PERL_UNUSED_VAR(cv);
196
197     SP -= items;
198
199     switch((U32)items) {
200     case 3: {
201         SV * svarg2;
202         vs = sv_newmortal();
203         svarg2 = ST(2);
204         Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
205         break;
206     }
207     case 2:
208         vs = ST(1);
209     /* Just in case this is something like a tied hash */
210         SvGETMAGIC(vs);
211         if(SvOK(vs))
212             break;
213         /* fall through */
214     case 1:
215         /* no param or explicit undef */
216         /* create empty object */
217         vs = sv_newmortal();
218         sv_setpvs(vs,"undef");
219         break;
220     default:
221     case 0:
222         Perl_croak_nocontext("Usage: version::new(class, version)");
223     }
224
225     svarg0 = ST(0);
226     if ( sv_isobject(svarg0) ) {
227         /* get the class if called as an object method */
228         const HV * stash = SvSTASH(SvRV(svarg0));
229         classname = HvNAME_get(stash);
230         len       = HvNAMELEN_get(stash);
231 #ifdef HvNAMEUTF8
232         flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
233 #endif
234     }
235     else {
236         classname = SvPV_nomg(svarg0, len);
237         flags     = SvUTF8(svarg0);
238     }
239
240     rv = NEW_VERSION(vs);
241     if ( len != sizeof(VXS_CLASS)-1
242       || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
243         sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
244
245     VXS_RETURN_M_SV(rv);
246 }
247
248 #define VTYPECHECK(var, val, varname) \
249     STMT_START {                                                        \
250         SV * sv_vtc = val;                                              \
251         if (ISA_VERSION_OBJ(sv_vtc)) {                          \
252             (var) = SvRV(sv_vtc);                                               \
253         }                                                               \
254         else                                                            \
255             Perl_croak_nocontext(varname " is not of type version");    \
256     } STMT_END
257
258 VXS(version_stringify)
259 {
260      dXSARGS;
261      if (items < 1)
262          croak_xs_usage(cv, "lobj, ...");
263      SP -= items;
264      {
265           SV *  lobj;
266           VTYPECHECK(lobj, ST(0), "lobj");
267
268           VXS_RETURN_M_SV(VSTRINGIFY(lobj));
269      }
270 }
271
272 VXS(version_numify)
273 {
274      dXSARGS;
275      if (items < 1)
276          croak_xs_usage(cv, "lobj, ...");
277      SP -= items;
278      {
279           SV *  lobj;
280           VTYPECHECK(lobj, ST(0), "lobj");
281           VXS_RETURN_M_SV(VNUMIFY(lobj));
282      }
283 }
284
285 VXS(version_normal)
286 {
287      dXSARGS;
288      if (items != 1)
289          croak_xs_usage(cv, "ver");
290      SP -= items;
291      {
292           SV *  ver;
293           VTYPECHECK(ver, ST(0), "ver");
294
295           VXS_RETURN_M_SV(VNORMAL(ver));
296      }
297 }
298
299 VXS(version_vcmp)
300 {
301      dXSARGS;
302      if (items < 2)
303          croak_xs_usage(cv, "lobj, robj, ...");
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 int swap = items > 2 ? SvTRUE(ST(2)) : 0;
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                VXS_RETURN_M_SV(rs);
330           }
331      }
332 }
333
334 VXS(version_boolean)
335 {
336     dXSARGS;
337     SV *lobj;
338     if (items < 1)
339         croak_xs_usage(cv, "lobj, ...");
340     SP -= items;
341     VTYPECHECK(lobj, ST(0), "lobj");
342     {
343         SV * const rs =
344             newSViv( VCMP(lobj,
345                           sv_2mortal(NEW_VERSION(
346                                         sv_2mortal(newSVpvs("0"))
347                                     ))
348                          )
349                    );
350         VXS_RETURN_M_SV(rs);
351     }
352 }
353
354 VXS(version_noop)
355 {
356     dXSARGS;
357     if (items < 1)
358         croak_xs_usage(cv, "lobj, ...");
359     if (ISA_VERSION_OBJ(ST(0)))
360         Perl_croak(aTHX_ "operation not supported with version object");
361     else
362         Perl_croak(aTHX_ "lobj is not of type version");
363     XSRETURN_EMPTY;
364 }
365
366 static
367 void
368 S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
369 {
370     dXSARGS;
371     if (items != 1)
372         croak_xs_usage(cv, "lobj");
373     {
374         SV *lobj = POPs;
375         SV *ret;
376         VTYPECHECK(lobj, lobj, "lobj");
377         if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) )
378             ret = &PL_sv_yes;
379         else
380             ret = &PL_sv_no;
381         PUSHs(ret);
382         PUTBACK;
383         return;
384     }
385 }
386
387 VXS(version_is_alpha)
388 {
389     S_version_check_key(aTHX_ cv, "alpha", 5);
390 }
391
392 VXS(version_qv)
393 {
394     dXSARGS;
395     PERL_UNUSED_ARG(cv);
396     SP -= items;
397     {
398         SV * ver = ST(0);
399         SV * sv0 = ver;
400         SV * rv;
401         STRLEN len = 0;
402         const char * classname = "";
403         U32 flags = 0;
404         if ( items == 2 ) {
405             SV * sv1 = ST(1);
406             SvGETMAGIC(sv1);
407             if (SvOK(sv1)) {
408                 ver = sv1;
409             }
410             else {
411                 Perl_croak(aTHX_ "Invalid version format (version required)");
412             }
413             if ( sv_isobject(sv0) ) { /* class called as an object method */
414                 const HV * stash = SvSTASH(SvRV(sv0));
415                 classname = HvNAME_get(stash);
416                 len       = HvNAMELEN_get(stash);
417 #ifdef HvNAMEUTF8
418                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
419 #endif
420             }
421             else {
422                classname = SvPV(sv0, len);
423                 flags     = SvUTF8(sv0);
424             }
425         }
426         if ( !SvVOK(ver) ) { /* not already a v-string */
427             rv = sv_newmortal();
428             SvSetSV_nosteal(rv,ver); /* make a duplicate */
429             UPG_VERSION(rv, TRUE);
430         } else {
431             rv = sv_2mortal(NEW_VERSION(ver));
432         }
433         if ( items == 2 && (len != 7
434                 || strcmp(classname,"version")) ) { /* inherited new() */
435             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
436         }
437         PUSHs(rv);
438     }
439     PUTBACK;
440     return;
441 }
442
443
444 VXS(version_is_qv)
445 {
446     S_version_check_key(aTHX_ cv, "qv", 2);
447 }
448
449 #endif