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_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 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