APItest/t/utf8_warn_base.pl: Rename and modify test
[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
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 #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
191 VXS(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         /* drop 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
271 VXS(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
285 VXS(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
298 VXS(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
312 VXS(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
347 VXS(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
367 VXS(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
379 static
380 void
381 S_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
400 VXS(version_is_alpha)
401 {
402     S_version_check_key(aTHX_ cv, "alpha", 5);
403 }
404
405 VXS(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
461 VXS(version_is_qv)
462 {
463     S_version_check_key(aTHX_ cv, "qv", 2);
464 }
465
466 #endif