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, 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
  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                 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
 186 VXS(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
 258 VXS(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
 272 VXS(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
 285 VXS(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
 299 VXS(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
 334 VXS(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
 354 VXS(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
 366 static
 367 void
 368 S_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
 387 VXS(version_is_alpha)
 388 {
 389     S_version_check_key(aTHX_ cv, "alpha", 5);
 390 }
 391
 392 VXS(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
 444 VXS(version_is_qv)
 445 {
 446     S_version_check_key(aTHX_ cv, "qv", 2);
 447 }
 448
 449 #endif