| 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 |