vxs.inc

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