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