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