xref: /openbsd/gnu/usr.bin/perl/vxs.inc (revision cecf84d4) 
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
75typedef HEK HVNAME;
76#  ifndef HEKf
77#    define HEKfARG(arg)	((void*)(sv_2mortal(newSVhek(arg))))
78#    define HEKf		SVf
79#  endif
80#else
81typedef char HVNAME;
82#  define HvNAME_HEK	HvNAME_get
83#  define HEKfARG(arg)	arg
84#  define HEKf		"s"
85#endif
86
87VXS(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
186VXS(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
268VXS(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
283VXS(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
297VXS(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
312VXS(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
348VXS(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
369VXS(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
382static
383void
384S_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
404VXS(version_is_alpha)
405{
406    S_version_check_key(aTHX_ cv, "alpha", 5);
407}
408
409VXS(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
466VXS(version_is_qv)
467{
468    S_version_check_key(aTHX_ cv, "qv", 2);
469}
470
471#endif
472