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 #else
   8 #  define VXS_CLASS "version::vxs"
   9 #  define VXSp(name) VXS_##name
  10 #endif
  11 #define VXS(name) XS(VXSp(name))
  12
  13 #ifdef VXS_XSUB_DETAILS
  14 #  ifdef PERL_CORE
  15     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
  16 #  else
  17     {VXS_CLASS "::_VERSION", VXS_UNIVERSAL_VERSION, NULL},
  18 #  endif
  19     {VXS_CLASS "::()", VXSp(version_noop), NULL},
  20     {VXS_CLASS "::new", VXSp(version_new), NULL},
  21     {VXS_CLASS "::parse", VXSp(version_new), NULL},
  22     {VXS_CLASS "::(\"\"", VXSp(version_stringify), NULL},
  23     {VXS_CLASS "::stringify", VXSp(version_stringify), NULL},
  24     {VXS_CLASS "::(0+", VXSp(version_numify), NULL},
  25     {VXS_CLASS "::numify", VXSp(version_numify), NULL},
  26     {VXS_CLASS "::normal", VXSp(version_normal), NULL},
  27     {VXS_CLASS "::(cmp", VXSp(version_vcmp), NULL},
  28     {VXS_CLASS "::(<=>", VXSp(version_vcmp), NULL},
  29 #  ifdef PERL_CORE
  30     {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
  31 #  else
  32     {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL},
  33 #  endif
  34     {VXS_CLASS "::(bool", VXSp(version_boolean), NULL},
  35     {VXS_CLASS "::boolean", VXSp(version_boolean), NULL},
  36     {VXS_CLASS "::(+", VXSp(version_noop), NULL},
  37     {VXS_CLASS "::(-", VXSp(version_noop), NULL},
  38     {VXS_CLASS "::(*", VXSp(version_noop), NULL},
  39     {VXS_CLASS "::(/", VXSp(version_noop), NULL},
  40     {VXS_CLASS "::(+=", VXSp(version_noop), NULL},
  41     {VXS_CLASS "::(-=", VXSp(version_noop), NULL},
  42     {VXS_CLASS "::(*=", VXSp(version_noop), NULL},
  43     {VXS_CLASS "::(/=", VXSp(version_noop), NULL},
  44     {VXS_CLASS "::(abs", VXSp(version_noop), NULL},
  45     {VXS_CLASS "::(nomethod", VXSp(version_noop), NULL},
  46     {VXS_CLASS "::noop", VXSp(version_noop), NULL},
  47     {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), NULL},
  48     {VXS_CLASS "::qv", VXSp(version_qv), NULL},
  49     {VXS_CLASS "::declare", VXSp(version_qv), NULL},
  50     {VXS_CLASS "::is_qv", VXSp(version_is_qv), NULL},
  51 #else
  52
  53 #ifndef dVAR
  54 #  define dVAR
  55 #endif
  56
  57 #ifdef HvNAME_HEK
  58 typedef HEK HVNAME;
  59 #  ifndef HEKf
  60 #    define HEKfARG(arg)        ((void*)(sv_2mortal(newSVhek(arg))))
  61 #    define HEKf                SVf
  62 #  endif
  63 #else
  64 typedef char HVNAME;
  65 #  define HvNAME_HEK    HvNAME_get
  66 #  define HEKfARG(arg)  arg
  67 #  define HEKf          "s"
  68 #endif
  69
  70 VXS(UNIVERSAL_VERSION)
  71 {
  72     dVAR;
  73     dXSARGS;
  74     HV *pkg;
  75     GV **gvp;
  76     GV *gv;
  77     SV *ret;
  78     SV *sv;
  79     const char *undef;
  80     PERL_UNUSED_ARG(cv);
  81
  82     if (items < 1)
  83        Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
  84
  85     sv = ST(0);
  86
  87     if (SvROK(sv)) {
  88         sv = (SV*)SvRV(sv);
  89         if (!SvOBJECT(sv))
  90             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
  91         pkg = SvSTASH(sv);
  92     }
  93     else {
  94         pkg = gv_stashsv(sv, FALSE);
  95     }
  96
  97     gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;
  98
  99     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 100         sv = sv_mortalcopy(sv);
 101         if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
 102             UPG_VERSION(sv, FALSE);
 103         undef = NULL;
 104     }
 105     else {
 106         sv = ret = &PL_sv_undef;
 107         undef = "(undef)";
 108     }
 109
 110     if (items > 1) {
 111         SV *req = ST(1);
 112
 113         if (undef) {
 114             if (pkg) {
 115                 const HVNAME* const name = HvNAME_HEK(pkg);
 116 #if PERL_VERSION == 5
 117                 Perl_croak(aTHX_ "%s version %s required--this is only version ",
 118                             name, SvPVx_nolen_const(req));
 119 #else
 120                 Perl_croak(aTHX_
 121                            "%"HEKf" does not define $%"HEKf
 122                            "::VERSION--version check failed",
 123                            HEKfARG(name), HEKfARG(name));
 124 #endif
 125             }
 126             else {
 127 #if PERL_VERSION >= 8
 128                 Perl_croak(aTHX_
 129                              "%"SVf" defines neither package nor VERSION--version check failed",
 130                              (void*)(ST(0)) );
 131 #else
 132                 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
 133                            SvPVx_nolen_const(ST(0)),
 134                            SvPVx_nolen_const(ST(0)) );
 135 #endif
 136             }
 137         }
 138
 139         if ( ! ISA_CLASS_OBJ(req, "version")) {
 140             /* req may very well be R/O, so create a new object */
 141             req = sv_2mortal( NEW_VERSION(req) );
 142         }
 143
 144         if ( VCMP( req, sv ) > 0 ) {
 145             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 146                 req = VNORMAL(req);
 147                 sv  = VNORMAL(sv);
 148             }
 149             else {
 150                 req = VSTRINGIFY(req);
 151                 sv  = VSTRINGIFY(sv);
 152             }
 153             Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 154                 "this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)),
 155                 SVfARG(sv_2mortal(req)),
 156                 SVfARG(sv_2mortal(sv)));
 157         }
 158     }
 159     ST(0) = ret;
 160
 161     /* if the package's $VERSION is not undef, it is upgraded to be a version object */
 162     if (ISA_CLASS_OBJ(sv, "version")) {
 163         ST(0) = sv_2mortal(VSTRINGIFY(sv));
 164     } else {
 165         ST(0) = sv;
 166     }
 167
 168     XSRETURN(1);
 169 }
 170
 171 VXS(version_new)
 172 {
 173     dVAR;
 174     dXSARGS;
 175     PERL_UNUSED_VAR(cv);
 176     SV *vs = items ? ST(1) : &PL_sv_undef;
 177     SV *rv;
 178     const char * classname = "";
 179     STRLEN len;
 180     U32 flags = 0;
 181     SP -= items;
 182
 183     if (items > 3 || items == 0)
 184         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 185
 186     /* Just in case this is something like a tied hash */
 187     SvGETMAGIC(vs);
 188
 189     if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 190         /* create empty object */
 191         vs = sv_newmortal();
 192         sv_setpvs(vs,"undef");
 193     }
 194     else if (items == 3 ) {
 195         vs = sv_newmortal();
 196 #if PERL_VERSION == 5
 197         sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
 198 #else
 199         Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 200 #endif
 201     }
 202     if ( sv_isobject(ST(0)) ) {
 203         /* get the class if called as an object method */
 204         const HV * stash = SvSTASH(SvRV(ST(0)));
 205         classname = HvNAME_get(stash);
 206         len       = HvNAMELEN_get(stash);
 207 #ifdef HvNAMEUTF8
 208         flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 209 #endif
 210     }
 211     else {
 212         classname = SvPV(ST(0), len);
 213         flags     = SvUTF8(ST(0));
 214     }
 215
 216     rv = NEW_VERSION(vs);
 217     if ( len != sizeof(VXS_CLASS)-1
 218       || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
 219 #if PERL_VERSION == 5
 220         sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
 221 #else
 222         sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 223 #endif
 224
 225     mPUSHs(rv);
 226     PUTBACK;
 227     return;
 228 }
 229
 230 #define VTYPECHECK(var, val, varname) \
 231     STMT_START {                                                        \
 232         if (ISA_CLASS_OBJ(val, "version")) {                            \
 233             (var) = SvRV(val);                                          \
 234         }                                                               \
 235         else                                                            \
 236             Perl_croak(aTHX_ varname " is not of type version");        \
 237     } STMT_END
 238
 239 VXS(version_stringify)
 240 {
 241      dVAR;
 242      dXSARGS;
 243      if (items < 1)
 244          croak_xs_usage(cv, "lobj, ...");
 245      SP -= items;
 246      {
 247           SV *  lobj;
 248           VTYPECHECK(lobj, ST(0), "lobj");
 249
 250           mPUSHs(VSTRINGIFY(lobj));
 251
 252           PUTBACK;
 253           return;
 254      }
 255 }
 256
 257 VXS(version_numify)
 258 {
 259      dVAR;
 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           mPUSHs(VNUMIFY(lobj));
 268           PUTBACK;
 269           return;
 270      }
 271 }
 272
 273 VXS(version_normal)
 274 {
 275      dVAR;
 276      dXSARGS;
 277      if (items != 1)
 278          croak_xs_usage(cv, "ver");
 279      SP -= items;
 280      {
 281           SV *  ver;
 282           VTYPECHECK(ver, ST(0), "ver");
 283
 284           mPUSHs(VNORMAL(ver));
 285
 286           PUTBACK;
 287           return;
 288      }
 289 }
 290
 291 VXS(version_vcmp)
 292 {
 293      dVAR;
 294      dXSARGS;
 295      if (items < 1)
 296          croak_xs_usage(cv, "lobj, ...");
 297      SP -= items;
 298      {
 299           SV *  lobj;
 300           VTYPECHECK(lobj, ST(0), "lobj");
 301           {
 302                SV       *rs;
 303                SV       *rvs;
 304                SV * robj = ST(1);
 305                const IV  swap = (IV)SvIV(ST(2));
 306
 307                if ( !ISA_CLASS_OBJ(robj, "version::vxs") )
 308                {
 309                     robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
 310                     sv_2mortal(robj);
 311                }
 312                rvs = SvRV(robj);
 313
 314                if ( swap )
 315                {
 316                     rs = newSViv(VCMP(rvs,lobj));
 317                }
 318                else
 319                {
 320                     rs = newSViv(VCMP(lobj,rvs));
 321                }
 322
 323                mPUSHs(rs);
 324           }
 325
 326           PUTBACK;
 327           return;
 328      }
 329 }
 330
 331 VXS(version_boolean)
 332 {
 333     dVAR;
 334     dXSARGS;
 335     SV *lobj;
 336     if (items < 1)
 337         croak_xs_usage(cv, "lobj, ...");
 338     SP -= items;
 339     VTYPECHECK(lobj, ST(0), "lobj");
 340     {
 341         SV * const rs =
 342             newSViv( VCMP(lobj,
 343                           sv_2mortal(NEW_VERSION(
 344                                         sv_2mortal(newSVpvs("0"))
 345                                     ))
 346                          )
 347                    );
 348         mPUSHs(rs);
 349         PUTBACK;
 350         return;
 351     }
 352 }
 353
 354 VXS(version_noop)
 355 {
 356     dVAR;
 357     dXSARGS;
 358     if (items < 1)
 359         croak_xs_usage(cv, "lobj, ...");
 360     if (ISA_CLASS_OBJ(ST(0), "version"))
 361         Perl_croak(aTHX_ "operation not supported with version object");
 362     else
 363         Perl_croak(aTHX_ "lobj is not of type version");
 364     XSRETURN_EMPTY;
 365 }
 366
 367 VXS(version_is_alpha)
 368 {
 369     dVAR;
 370     dXSARGS;
 371     if (items != 1)
 372         croak_xs_usage(cv, "lobj");
 373     SP -= items;
 374     {
 375         SV *lobj;
 376         VTYPECHECK(lobj, ST(0), "lobj");
 377         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 378             XSRETURN_YES;
 379         else
 380             XSRETURN_NO;
 381         PUTBACK;
 382         return;
 383     }
 384 }
 385
 386 VXS(version_qv)
 387 {
 388     dVAR;
 389     dXSARGS;
 390     PERL_UNUSED_ARG(cv);
 391     SP -= items;
 392     {
 393         SV * ver = ST(0);
 394         SV * rv;
 395         STRLEN len = 0;
 396         const char * classname = "";
 397         U32 flags = 0;
 398         if ( items == 2 ) {
 399             SvGETMAGIC(ST(1));
 400             if (SvOK(ST(1))) {
 401                 ver = ST(1);
 402             }
 403             else {
 404                 Perl_croak(aTHX_ "Invalid version format (version required)");
 405             }
 406             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
 407                 const HV * stash = SvSTASH(SvRV(ST(0)));
 408                 classname = HvNAME_get(stash);
 409                 len       = HvNAMELEN_get(stash);
 410 #ifdef HvNAMEUTF8
 411                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 412 #endif
 413             }
 414             else {
 415                classname = SvPV(ST(0), len);
 416                 flags     = SvUTF8(ST(0));
 417             }
 418         }
 419         if ( !SvVOK(ver) ) { /* not already a v-string */
 420             rv = sv_newmortal();
 421             sv_setsv(rv,ver); /* make a duplicate */
 422             UPG_VERSION(rv, TRUE);
 423         } else {
 424             rv = sv_2mortal(NEW_VERSION(ver));
 425         }
 426         if ( items == 2 && (len != 7
 427                 || strcmp(classname,"version")) ) { /* inherited new() */
 428 #if PERL_VERSION == 5
 429             sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
 430 #else
 431             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 432 #endif
 433         }
 434         PUSHs(rv);
 435     }
 436     PUTBACK;
 437     return;
 438 }
 439
 440 VXS(version_is_qv)
 441 {
 442     dVAR;
 443     dXSARGS;
 444     if (items != 1)
 445         croak_xs_usage(cv, "lobj");
 446     SP -= items;
 447     {
 448         SV *lobj;
 449         VTYPECHECK(lobj, ST(0), "lobj");
 450         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 451             XSRETURN_YES;
 452         else
 453             XSRETURN_NO;
 454         PUTBACK;
 455         return;
 456     }
 457 }
 458
 459 #endif