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 XS(XS_UNIVERSAL_VERSION)
  55 {
  56     dVAR;
  57     dXSARGS;
  58     HV *pkg;
  59     GV **gvp;
  60     GV *gv;
  61     SV *sv;
  62     const char *undef;
  63     PERL_UNUSED_ARG(cv);
  64
  65     if (SvROK(ST(0))) {
  66         sv = MUTABLE_SV(SvRV(ST(0)));
  67         if (!SvOBJECT(sv))
  68             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
  69         pkg = SvSTASH(sv);
  70     }
  71     else {
  72         pkg = gv_stashsv(ST(0), 0);
  73     }
  74
  75     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
  76
  77     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
  78         SV * const nsv = sv_newmortal();
  79         sv_setsv(nsv, sv);
  80         sv = nsv;
  81         if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
  82             upg_version(sv, FALSE);
  83
  84         undef = NULL;
  85     }
  86     else {
  87         sv = &PL_sv_undef;
  88         undef = "(undef)";
  89     }
  90
  91     if (items > 1) {
  92         SV *req = ST(1);
  93
  94         if (undef) {
  95             if (pkg) {
  96                 const HEK * const name = HvNAME_HEK(pkg);
  97                 Perl_croak(aTHX_
  98                            "%"HEKf" does not define $%"HEKf
  99                            "::VERSION--version check failed",
 100                            HEKfARG(name), HEKfARG(name));
 101             } else {
 102                 Perl_croak(aTHX_
 103                              "%"SVf" defines neither package nor VERSION--version check failed",
 104                              SVfARG(ST(0)) );
 105             }
 106         }
 107
 108         if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
 109             /* req may very well be R/O, so create a new object */
 110             req = sv_2mortal( new_version(req) );
 111         }
 112
 113         if ( vcmp( req, sv ) > 0 ) {
 114             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 115                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 116                        "this is only version %"SVf"",
 117                        HEKfARG(HvNAME_HEK(pkg)),
 118                        SVfARG(sv_2mortal(vnormal(req))),
 119                        SVfARG(sv_2mortal(vnormal(sv))));
 120             } else {
 121                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 122                        "this is only version %"SVf,
 123                        HEKfARG(HvNAME_HEK(pkg)),
 124                        SVfARG(sv_2mortal(vstringify(req))),
 125                        SVfARG(sv_2mortal(vstringify(sv))));
 126             }
 127         }
 128     }
 129
 130     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 131         ST(0) = sv_2mortal(vstringify(sv));
 132     } else {
 133         ST(0) = sv;
 134     }
 135
 136     XSRETURN(1);
 137 }
 138
 139 XS(XS_version_new)
 140 {
 141     dVAR;
 142     dXSARGS;
 143     if (items > 3 || items < 1)
 144         croak_xs_usage(cv, "class, version");
 145     SP -= items;
 146     {
 147         SV *vs = ST(1);
 148         SV *rv;
 149         STRLEN len;
 150         const char *classname;
 151         U32 flags;
 152
 153         /* Just in case this is something like a tied hash */
 154         SvGETMAGIC(vs);
 155
 156         if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
 157             const HV * stash = SvSTASH(SvRV(ST(0)));
 158             classname = HvNAME(stash);
 159             len       = HvNAMELEN(stash);
 160             flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 161         }
 162         else {
 163             classname = SvPV(ST(0), len);
 164             flags     = SvUTF8(ST(0));
 165         }
 166
 167         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 168             /* create empty object */
 169             vs = sv_newmortal();
 170             sv_setpvs(vs, "0");
 171         }
 172         else if ( items == 3 ) {
 173             vs = sv_newmortal();
 174             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 175         }
 176
 177         rv = new_version(vs);
 178         if ( strnNE(classname,"version", len) ) /* inherited new() */
 179             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 180
 181         mPUSHs(rv);
 182         PUTBACK;
 183         return;
 184     }
 185 }
 186
 187 XS(XS_version_stringify)
 188 {
 189      dVAR;
 190      dXSARGS;
 191      if (items < 1)
 192          croak_xs_usage(cv, "lobj, ...");
 193      SP -= items;
 194      {
 195           SV *  lobj = ST(0);
 196
 197           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 198                lobj = SvRV(lobj);
 199           }
 200           else
 201                Perl_croak(aTHX_ "lobj is not of type version");
 202
 203           mPUSHs(vstringify(lobj));
 204
 205           PUTBACK;
 206           return;
 207      }
 208 }
 209
 210 XS(XS_version_numify)
 211 {
 212      dVAR;
 213      dXSARGS;
 214      if (items < 1)
 215          croak_xs_usage(cv, "lobj, ...");
 216      SP -= items;
 217      {
 218           SV *  lobj = ST(0);
 219
 220           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 221                lobj = SvRV(lobj);
 222           }
 223           else
 224                Perl_croak(aTHX_ "lobj is not of type version");
 225
 226           mPUSHs(vnumify(lobj));
 227
 228           PUTBACK;
 229           return;
 230      }
 231 }
 232
 233 XS(XS_version_normal)
 234 {
 235      dVAR;
 236      dXSARGS;
 237      if (items < 1)
 238          croak_xs_usage(cv, "lobj, ...");
 239      SP -= items;
 240      {
 241           SV *  lobj = ST(0);
 242
 243           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 244                lobj = SvRV(lobj);
 245           }
 246           else
 247                Perl_croak(aTHX_ "lobj is not of type version");
 248
 249           mPUSHs(vnormal(lobj));
 250
 251           PUTBACK;
 252           return;
 253      }
 254 }
 255
 256 XS(XS_version_vcmp)
 257 {
 258      dVAR;
 259      dXSARGS;
 260      if (items < 1)
 261          croak_xs_usage(cv, "lobj, ...");
 262      SP -= items;
 263      {
 264           SV *  lobj = ST(0);
 265
 266           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 267                lobj = SvRV(lobj);
 268           }
 269           else
 270                Perl_croak(aTHX_ "lobj is not of type version");
 271
 272           {
 273                SV       *rs;
 274                SV       *rvs;
 275                SV * robj = ST(1);
 276                const IV  swap = (IV)SvIV(ST(2));
 277
 278                if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
 279                {
 280                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
 281                     sv_2mortal(robj);
 282                }
 283                rvs = SvRV(robj);
 284
 285                if ( swap )
 286                {
 287                     rs = newSViv(vcmp(rvs,lobj));
 288                }
 289                else
 290                {
 291                     rs = newSViv(vcmp(lobj,rvs));
 292                }
 293
 294                mPUSHs(rs);
 295           }
 296
 297           PUTBACK;
 298           return;
 299      }
 300 }
 301
 302 XS(XS_version_boolean)
 303 {
 304     dVAR;
 305     dXSARGS;
 306     if (items < 1)
 307         croak_xs_usage(cv, "lobj, ...");
 308     SP -= items;
 309     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 310         SV * const lobj = SvRV(ST(0));
 311         SV * const rs =
 312             newSViv( vcmp(lobj,
 313                           sv_2mortal(new_version(
 314                                         sv_2mortal(newSVpvs("0"))
 315                                     ))
 316                          )
 317                    );
 318         mPUSHs(rs);
 319         PUTBACK;
 320         return;
 321     }
 322     else
 323         Perl_croak(aTHX_ "lobj is not of type version");
 324 }
 325
 326 XS(XS_version_noop)
 327 {
 328     dVAR;
 329     dXSARGS;
 330     if (items < 1)
 331         croak_xs_usage(cv, "lobj, ...");
 332     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
 333         Perl_croak(aTHX_ "operation not supported with version object");
 334     else
 335         Perl_croak(aTHX_ "lobj is not of type version");
 336 #ifndef HASATTRIBUTE_NORETURN
 337     XSRETURN_EMPTY;
 338 #endif
 339 }
 340
 341 XS(XS_version_is_alpha)
 342 {
 343     dVAR;
 344     dXSARGS;
 345     if (items != 1)
 346         croak_xs_usage(cv, "lobj");
 347     SP -= items;
 348     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 349         SV * const lobj = ST(0);
 350         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 351             XSRETURN_YES;
 352         else
 353             XSRETURN_NO;
 354         PUTBACK;
 355         return;
 356     }
 357     else
 358         Perl_croak(aTHX_ "lobj is not of type version");
 359 }
 360
 361 XS(XS_version_qv)
 362 {
 363     dVAR;
 364     dXSARGS;
 365     PERL_UNUSED_ARG(cv);
 366     SP -= items;
 367     {
 368         SV * ver = ST(0);
 369         SV * rv;
 370         STRLEN len = 0;
 371         const char * classname = "";
 372         U32 flags = 0;
 373         if ( items == 2 ) {
 374             SvGETMAGIC(ST(1));
 375             if (SvOK(ST(1))) {
 376                 ver = ST(1);
 377             }
 378             else {
 379                 Perl_croak(aTHX_ "Invalid version format (version required)");
 380             }
 381             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
 382                 const HV * stash = SvSTASH(SvRV(ST(0)));
 383                 classname = HvNAME(stash);
 384                 len       = HvNAMELEN(stash);
 385                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 386             }
 387             else {
 388                classname = SvPV(ST(0), len);
 389                 flags     = SvUTF8(ST(0));
 390             }
 391         }
 392         if ( !SvVOK(ver) ) { /* not already a v-string */
 393             rv = sv_newmortal();
 394             sv_setsv(rv,ver); /* make a duplicate */
 395             upg_version(rv, TRUE);
 396         } else {
 397             rv = sv_2mortal(new_version(ver));
 398         }
 399         if ( items == 2
 400                 && strnNE(classname,"version", len) ) { /* inherited new() */
 401             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 402         }
 403         PUSHs(rv);
 404     }
 405     PUTBACK;
 406     return;
 407 }
 408
 409 XS(XS_version_is_qv)
 410 {
 411     dVAR;
 412     dXSARGS;
 413     if (items != 1)
 414         croak_xs_usage(cv, "lobj");
 415     SP -= items;
 416     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 417         SV * const lobj = ST(0);
 418         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 419             XSRETURN_YES;
 420         else
 421             XSRETURN_NO;
 422         PUTBACK;
 423         return;
 424     }
 425     else
 426         Perl_croak(aTHX_ "lobj is not of type version");
 427 }
 428
 429 #endif