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#if PERL_VERSION == 5
137		Perl_croak(aTHX_ "%s version %s required--this is only version ",
138			    name, SvPVx_nolen_const(req));
139#else
140		Perl_croak(aTHX_
141			   "%" HEKf " does not define $%" HEKf
142			   "::VERSION--version check failed",
143			   HEKfARG(name), HEKfARG(name));
144#endif
145	    }
146	    else {
147#if PERL_VERSION >= 8
148		Perl_croak(aTHX_
149			     "%" SVf " defines neither package nor VERSION--"
150                             "version check failed",
151			     (void*)(ST(0)) );
152#else
153		Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
154			   SvPVx_nolen_const(ST(0)),
155			   SvPVx_nolen_const(ST(0)) );
156#endif
157	    }
158	}
159
160	if ( ! ISA_VERSION_OBJ(req) ) {
161	    /* req may very well be R/O, so create a new object */
162	    req = sv_2mortal( NEW_VERSION(req) );
163	}
164
165	if ( VCMP( req, sv ) > 0 ) {
166	    if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
167		req = VNORMAL(req);
168		sv  = VNORMAL(sv);
169	    }
170	    else {
171		req = VSTRINGIFY(req);
172		sv  = VSTRINGIFY(sv);
173	    }
174	    Perl_croak(aTHX_ "%" HEKf " version %" SVf " required--"
175		"this is only version %" SVf, HEKfARG(HvNAME_HEK(pkg)),
176		SVfARG(sv_2mortal(req)),
177		SVfARG(sv_2mortal(sv)));
178	}
179    }
180
181    /* if the package's $VERSION is not undef, it is upgraded to be a version object */
182    if (ISA_VERSION_OBJ(sv)) {
183	ST(0) = sv_2mortal(VSTRINGIFY(sv));
184    } else {
185	ST(0) = sv;
186    }
187
188    XSRETURN(1);
189}
190
191VXS(version_new)
192{
193    dXSARGS;
194    SV *vs;
195    SV *rv;
196    const char * classname = "";
197    STRLEN len;
198    U32 flags = 0;
199    SV * svarg0 = NULL;
200    PERL_UNUSED_VAR(cv);
201
202    SP -= items;
203
204    switch((U32)items) {
205    case 3: {
206        SV * svarg2;
207        vs = sv_newmortal();
208        svarg2 = ST(2);
209#if PERL_VERSION == 5
210        sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2));
211#else
212        Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
213#endif
214        break;
215    }
216    case 2:
217        vs = ST(1);
218    /* Just in case this is something like a tied hash */
219        SvGETMAGIC(vs);
220        if(SvOK(vs))
221            break;
222        /* fall through */
223    case 1:
224        /* no param or explicit undef */
225        /* create empty object */
226        vs = sv_newmortal();
227        sv_setpvs(vs,"undef");
228        break;
229    default:
230    case 0:
231        Perl_croak_nocontext("Usage: version::new(class, version)");
232    }
233
234    svarg0 = ST(0);
235    if ( sv_isobject(svarg0) ) {
236	/* get the class if called as an object method */
237	const HV * stash = SvSTASH(SvRV(svarg0));
238	classname = HvNAME_get(stash);
239	len	  = HvNAMELEN_get(stash);
240#ifdef HvNAMEUTF8
241	flags	  = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
242#endif
243    }
244    else {
245	classname = SvPV_nomg(svarg0, len);
246	flags     = SvUTF8(svarg0);
247    }
248
249    rv = NEW_VERSION(vs);
250    if ( len != sizeof(VXS_CLASS)-1
251      || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
252#if PERL_VERSION == 5
253        sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
254#else
255        sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
256#endif
257
258    VXS_RETURN_M_SV(rv);
259}
260
261#define VTYPECHECK(var, val, varname) \
262    STMT_START {							\
263	SV * sv_vtc = val;						\
264	if (ISA_VERSION_OBJ(sv_vtc)) {				\
265	    (var) = SvRV(sv_vtc);						\
266	}								\
267	else								\
268	    Perl_croak_nocontext(varname " is not of type version");	\
269    } STMT_END
270
271VXS(version_stringify)
272{
273     dXSARGS;
274     if (items < 1)
275	 croak_xs_usage(cv, "lobj, ...");
276     SP -= items;
277     {
278	  SV *	lobj;
279	  VTYPECHECK(lobj, ST(0), "lobj");
280
281	  VXS_RETURN_M_SV(VSTRINGIFY(lobj));
282     }
283}
284
285VXS(version_numify)
286{
287     dXSARGS;
288     if (items < 1)
289	 croak_xs_usage(cv, "lobj, ...");
290     SP -= items;
291     {
292	  SV *	lobj;
293	  VTYPECHECK(lobj, ST(0), "lobj");
294	  VXS_RETURN_M_SV(VNUMIFY(lobj));
295     }
296}
297
298VXS(version_normal)
299{
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
312VXS(version_vcmp)
313{
314     dXSARGS;
315     if (items < 1)
316	 croak_xs_usage(cv, "lobj, ...");
317     SP -= items;
318     {
319	  SV *	lobj;
320	  VTYPECHECK(lobj, ST(0), "lobj");
321	  {
322	       SV	*rs;
323	       SV	*rvs;
324	       SV * robj = ST(1);
325	       const IV	 swap = (IV)SvIV(ST(2));
326
327	       if ( !ISA_VERSION_OBJ(robj) )
328	       {
329		    robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)));
330	       }
331	       rvs = SvRV(robj);
332
333	       if ( swap )
334	       {
335		    rs = newSViv(VCMP(rvs,lobj));
336	       }
337	       else
338	       {
339		    rs = newSViv(VCMP(lobj,rvs));
340	       }
341
342	       VXS_RETURN_M_SV(rs);
343	  }
344     }
345}
346
347VXS(version_boolean)
348{
349    dXSARGS;
350    SV *lobj;
351    if (items < 1)
352	croak_xs_usage(cv, "lobj, ...");
353    SP -= items;
354    VTYPECHECK(lobj, ST(0), "lobj");
355    {
356	SV * const rs =
357	    newSViv( VCMP(lobj,
358			  sv_2mortal(NEW_VERSION(
359					sv_2mortal(newSVpvs("0"))
360				    ))
361			 )
362		   );
363	VXS_RETURN_M_SV(rs);
364    }
365}
366
367VXS(version_noop)
368{
369    dXSARGS;
370    if (items < 1)
371	croak_xs_usage(cv, "lobj, ...");
372    if (ISA_VERSION_OBJ(ST(0)))
373	Perl_croak(aTHX_ "operation not supported with version object");
374    else
375	Perl_croak(aTHX_ "lobj is not of type version");
376    XSRETURN_EMPTY;
377}
378
379static
380void
381S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
382{
383    dXSARGS;
384    if (items != 1)
385	croak_xs_usage(cv, "lobj");
386    {
387	SV *lobj = POPs;
388	SV *ret;
389	VTYPECHECK(lobj, lobj, "lobj");
390	if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) )
391	    ret = &PL_sv_yes;
392	else
393	    ret = &PL_sv_no;
394	PUSHs(ret);
395	PUTBACK;
396	return;
397    }
398}
399
400VXS(version_is_alpha)
401{
402    S_version_check_key(aTHX_ cv, "alpha", 5);
403}
404
405VXS(version_qv)
406{
407    dXSARGS;
408    PERL_UNUSED_ARG(cv);
409    SP -= items;
410    {
411	SV * ver = ST(0);
412	SV * sv0 = ver;
413	SV * rv;
414        STRLEN len = 0;
415        const char * classname = "";
416        U32 flags = 0;
417        if ( items == 2 ) {
418	    SV * sv1 = ST(1);
419	    SvGETMAGIC(sv1);
420	    if (SvOK(sv1)) {
421		ver = sv1;
422	    }
423	    else {
424		Perl_croak(aTHX_ "Invalid version format (version required)");
425	    }
426            if ( sv_isobject(sv0) ) { /* class called as an object method */
427                const HV * stash = SvSTASH(SvRV(sv0));
428                classname = HvNAME_get(stash);
429                len       = HvNAMELEN_get(stash);
430#ifdef HvNAMEUTF8
431                flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
432#endif
433            }
434            else {
435	       classname = SvPV(sv0, len);
436                flags     = SvUTF8(sv0);
437            }
438	}
439	if ( !SvVOK(ver) ) { /* not already a v-string */
440	    rv = sv_newmortal();
441	    SvSetSV_nosteal(rv,ver); /* make a duplicate */
442	    UPG_VERSION(rv, TRUE);
443	} else {
444	    rv = sv_2mortal(NEW_VERSION(ver));
445	}
446	if ( items == 2 && (len != 7
447                || strcmp(classname,"version")) ) { /* inherited new() */
448#if PERL_VERSION == 5
449	    sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
450#else
451	    sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
452#endif
453        }
454	PUSHs(rv);
455    }
456    PUTBACK;
457    return;
458}
459
460
461VXS(version_is_qv)
462{
463    S_version_check_key(aTHX_ cv, "qv", 2);
464}
465
466#endif
467