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