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