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