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