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
80typedef HEK HVNAME;
81#  ifndef HEKf
82#    define HEKfARG(arg)	((void*)(sv_2mortal(newSVhek(arg))))
83#    define HEKf		SVf
84#  endif
85#else
86typedef char HVNAME;
87#  define HvNAME_HEK	HvNAME_get
88#  define HEKfARG(arg)	arg
89#  define HEKf		"s"
90#endif
91
92VXS(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
186VXS(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
258VXS(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
272VXS(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
285VXS(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
299VXS(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
334VXS(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
354VXS(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
366static
367void
368S_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
387VXS(version_is_alpha)
388{
389    S_version_check_key(aTHX_ cv, "alpha", 5);
390}
391
392VXS(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
444VXS(version_is_qv)
445{
446    S_version_check_key(aTHX_ cv, "qv", 2);
447}
448
449#endif
450