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# define VXSp(name) XS_##name 7/* VXSXSDP = XSUB Details Proto */ 8# define VXSXSDP(x) x, 0 9#else 10# define VXS_CLASS "version::vxs" 11# define VXSp(name) VXS_##name 12/* proto member is unused in version, it is used in CORE by non version xsubs */ 13# define VXSXSDP(x) 14#endif 15 16#ifndef XS_INTERNAL 17# define XS_INTERNAL(name) static XSPROTO(name) 18#endif 19 20#define VXS(name) XS_INTERNAL(VXSp(name)); XS_INTERNAL(VXSp(name)) 21 22/* uses PUSHs, so SP must be at start, PUSHs sv on Perl stack, then returns from 23 xsub; this is a little more machine code/tailcall friendly than mPUSHs(foo); 24 PUTBACK; return; */ 25 26#define VXS_RETURN_M_SV(sv) \ 27 STMT_START { \ 28 SV * sv_vtc = sv; \ 29 PUSHs(sv_vtc); \ 30 PUTBACK; \ 31 sv_2mortal(sv_vtc); \ 32 return; \ 33 } STMT_END 34 35 36#ifdef VXS_XSUB_DETAILS 37# ifdef PERL_CORE 38 {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)}, 39# endif 40 {VXS_CLASS "::_VERSION", VXSp(universal_version), VXSXSDP(NULL)}, 41 {VXS_CLASS "::()", VXSp(version_noop), VXSXSDP(NULL)}, 42 {VXS_CLASS "::new", VXSp(version_new), VXSXSDP(NULL)}, 43 {VXS_CLASS "::parse", VXSp(version_new), VXSXSDP(NULL)}, 44 {VXS_CLASS "::(\"\"", VXSp(version_stringify), VXSXSDP(NULL)}, 45 {VXS_CLASS "::stringify", VXSp(version_stringify), VXSXSDP(NULL)}, 46 {VXS_CLASS "::(0+", VXSp(version_numify), VXSXSDP(NULL)}, 47 {VXS_CLASS "::numify", VXSp(version_numify), VXSXSDP(NULL)}, 48 {VXS_CLASS "::normal", VXSp(version_normal), VXSXSDP(NULL)}, 49 {VXS_CLASS "::(cmp", VXSp(version_vcmp), VXSXSDP(NULL)}, 50 {VXS_CLASS "::(<=>", VXSp(version_vcmp), VXSXSDP(NULL)}, 51# ifdef PERL_CORE 52 {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)}, 53# else 54 {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(NULL)}, 55# endif 56 {VXS_CLASS "::(bool", VXSp(version_boolean), VXSXSDP(NULL)}, 57 {VXS_CLASS "::boolean", VXSp(version_boolean), VXSXSDP(NULL)}, 58 {VXS_CLASS "::(+", VXSp(version_noop), VXSXSDP(NULL)}, 59 {VXS_CLASS "::(-", VXSp(version_noop), VXSXSDP(NULL)}, 60 {VXS_CLASS "::(*", VXSp(version_noop), VXSXSDP(NULL)}, 61 {VXS_CLASS "::(/", VXSp(version_noop), VXSXSDP(NULL)}, 62 {VXS_CLASS "::(+=", VXSp(version_noop), VXSXSDP(NULL)}, 63 {VXS_CLASS "::(-=", VXSp(version_noop), VXSXSDP(NULL)}, 64 {VXS_CLASS "::(*=", VXSp(version_noop), VXSXSDP(NULL)}, 65 {VXS_CLASS "::(/=", VXSp(version_noop), VXSXSDP(NULL)}, 66 {VXS_CLASS "::(abs", VXSp(version_noop), VXSXSDP(NULL)}, 67 {VXS_CLASS "::(nomethod", VXSp(version_noop), VXSXSDP(NULL)}, 68 {VXS_CLASS "::noop", VXSp(version_noop), VXSXSDP(NULL)}, 69 {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), VXSXSDP(NULL)}, 70 {VXS_CLASS "::qv", VXSp(version_qv), VXSXSDP(NULL)}, 71 {VXS_CLASS "::declare", VXSp(version_qv), VXSXSDP(NULL)}, 72 {VXS_CLASS "::is_qv", VXSp(version_is_qv), VXSXSDP(NULL)}, 73#else 74 75#ifndef dVAR 76# define dVAR 77#endif 78 79#ifdef HvNAME_HEK 80typedef HEK HVNAME; 81# ifndef HEKf 82# define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg)))) 83# define HEKf SVf 84# endif 85#else 86typedef char HVNAME; 87# define HvNAME_HEK HvNAME_get 88# define HEKfARG(arg) arg 89# define HEKf "s" 90#endif 91 92VXS(universal_version) 93{ 94 dXSARGS; 95 HV *pkg; 96 GV **gvp; 97 GV *gv; 98 SV *sv; 99 const char *undef; 100 PERL_UNUSED_ARG(cv); 101 102 if (items < 1) 103 Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)"); 104 105 sv = ST(0); 106 107 if (SvROK(sv)) { 108 sv = (SV*)SvRV(sv); 109 if (!SvOBJECT(sv)) 110 Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 111 pkg = SvSTASH(sv); 112 } 113 else { 114 pkg = gv_stashsv(sv, FALSE); 115 } 116 117 gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL; 118 119 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { 120 sv = sv_mortalcopy(sv); 121 if ( ! ISA_VERSION_OBJ(sv) ) 122 UPG_VERSION(sv, FALSE); 123 undef = NULL; 124 } 125 else { 126 sv = &PL_sv_undef; 127 undef = "(undef)"; 128 } 129 130 if (items > 1) { 131 SV *req = ST(1); 132 133 if (undef) { 134 if (pkg) { 135 const HVNAME* const name = HvNAME_HEK(pkg); 136#if PERL_VERSION == 5 137 Perl_croak(aTHX_ "%s version %s required--this is only version ", 138 name, SvPVx_nolen_const(req)); 139#else 140 Perl_croak(aTHX_ 141 "%" HEKf " does not define $%" HEKf 142 "::VERSION--version check failed", 143 HEKfARG(name), HEKfARG(name)); 144#endif 145 } 146 else { 147#if PERL_VERSION >= 8 148 Perl_croak(aTHX_ 149 "%" SVf " defines neither package nor VERSION--" 150 "version check failed", 151 (void*)(ST(0)) ); 152#else 153 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", 154 SvPVx_nolen_const(ST(0)), 155 SvPVx_nolen_const(ST(0)) ); 156#endif 157 } 158 } 159 160 if ( ! ISA_VERSION_OBJ(req) ) { 161 /* req may very well be R/O, so create a new object */ 162 req = sv_2mortal( NEW_VERSION(req) ); 163 } 164 165 if ( VCMP( req, sv ) > 0 ) { 166 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { 167 req = VNORMAL(req); 168 sv = VNORMAL(sv); 169 } 170 else { 171 req = VSTRINGIFY(req); 172 sv = VSTRINGIFY(sv); 173 } 174 Perl_croak(aTHX_ "%" HEKf " version %" SVf " required--" 175 "this is only version %" SVf, HEKfARG(HvNAME_HEK(pkg)), 176 SVfARG(sv_2mortal(req)), 177 SVfARG(sv_2mortal(sv))); 178 } 179 } 180 181 /* if the package's $VERSION is not undef, it is upgraded to be a version object */ 182 if (ISA_VERSION_OBJ(sv)) { 183 ST(0) = sv_2mortal(VSTRINGIFY(sv)); 184 } else { 185 ST(0) = sv; 186 } 187 188 XSRETURN(1); 189} 190 191VXS(version_new) 192{ 193 dXSARGS; 194 SV *vs; 195 SV *rv; 196 const char * classname = ""; 197 STRLEN len; 198 U32 flags = 0; 199 SV * svarg0 = NULL; 200 PERL_UNUSED_VAR(cv); 201 202 SP -= items; 203 204 switch((U32)items) { 205 case 3: { 206 SV * svarg2; 207 vs = sv_newmortal(); 208 svarg2 = ST(2); 209#if PERL_VERSION == 5 210 sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2)); 211#else 212 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2)); 213#endif 214 break; 215 } 216 case 2: 217 vs = ST(1); 218 /* Just in case this is something like a tied hash */ 219 SvGETMAGIC(vs); 220 if(SvOK(vs)) 221 break; 222 /* fall through */ 223 case 1: 224 /* no param or explicit undef */ 225 /* create empty object */ 226 vs = sv_newmortal(); 227 sv_setpvs(vs,"undef"); 228 break; 229 default: 230 case 0: 231 Perl_croak_nocontext("Usage: version::new(class, version)"); 232 } 233 234 svarg0 = ST(0); 235 if ( sv_isobject(svarg0) ) { 236 /* get the class if called as an object method */ 237 const HV * stash = SvSTASH(SvRV(svarg0)); 238 classname = HvNAME_get(stash); 239 len = HvNAMELEN_get(stash); 240#ifdef HvNAMEUTF8 241 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; 242#endif 243 } 244 else { 245 classname = SvPV_nomg(svarg0, len); 246 flags = SvUTF8(svarg0); 247 } 248 249 rv = NEW_VERSION(vs); 250 if ( len != sizeof(VXS_CLASS)-1 251 || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */ 252#if PERL_VERSION == 5 253 sv_bless(rv, gv_stashpv((char *)classname, GV_ADD)); 254#else 255 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); 256#endif 257 258 VXS_RETURN_M_SV(rv); 259} 260 261#define VTYPECHECK(var, val, varname) \ 262 STMT_START { \ 263 SV * sv_vtc = val; \ 264 if (ISA_VERSION_OBJ(sv_vtc)) { \ 265 (var) = SvRV(sv_vtc); \ 266 } \ 267 else \ 268 Perl_croak_nocontext(varname " is not of type version"); \ 269 } STMT_END 270 271VXS(version_stringify) 272{ 273 dXSARGS; 274 if (items < 1) 275 croak_xs_usage(cv, "lobj, ..."); 276 SP -= items; 277 { 278 SV * lobj; 279 VTYPECHECK(lobj, ST(0), "lobj"); 280 281 VXS_RETURN_M_SV(VSTRINGIFY(lobj)); 282 } 283} 284 285VXS(version_numify) 286{ 287 dXSARGS; 288 if (items < 1) 289 croak_xs_usage(cv, "lobj, ..."); 290 SP -= items; 291 { 292 SV * lobj; 293 VTYPECHECK(lobj, ST(0), "lobj"); 294 VXS_RETURN_M_SV(VNUMIFY(lobj)); 295 } 296} 297 298VXS(version_normal) 299{ 300 dXSARGS; 301 if (items != 1) 302 croak_xs_usage(cv, "ver"); 303 SP -= items; 304 { 305 SV * ver; 306 VTYPECHECK(ver, ST(0), "ver"); 307 308 VXS_RETURN_M_SV(VNORMAL(ver)); 309 } 310} 311 312VXS(version_vcmp) 313{ 314 dXSARGS; 315 if (items < 1) 316 croak_xs_usage(cv, "lobj, ..."); 317 SP -= items; 318 { 319 SV * lobj; 320 VTYPECHECK(lobj, ST(0), "lobj"); 321 { 322 SV *rs; 323 SV *rvs; 324 SV * robj = ST(1); 325 const IV swap = (IV)SvIV(ST(2)); 326 327 if ( !ISA_VERSION_OBJ(robj) ) 328 { 329 robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP))); 330 } 331 rvs = SvRV(robj); 332 333 if ( swap ) 334 { 335 rs = newSViv(VCMP(rvs,lobj)); 336 } 337 else 338 { 339 rs = newSViv(VCMP(lobj,rvs)); 340 } 341 342 VXS_RETURN_M_SV(rs); 343 } 344 } 345} 346 347VXS(version_boolean) 348{ 349 dXSARGS; 350 SV *lobj; 351 if (items < 1) 352 croak_xs_usage(cv, "lobj, ..."); 353 SP -= items; 354 VTYPECHECK(lobj, ST(0), "lobj"); 355 { 356 SV * const rs = 357 newSViv( VCMP(lobj, 358 sv_2mortal(NEW_VERSION( 359 sv_2mortal(newSVpvs("0")) 360 )) 361 ) 362 ); 363 VXS_RETURN_M_SV(rs); 364 } 365} 366 367VXS(version_noop) 368{ 369 dXSARGS; 370 if (items < 1) 371 croak_xs_usage(cv, "lobj, ..."); 372 if (ISA_VERSION_OBJ(ST(0))) 373 Perl_croak(aTHX_ "operation not supported with version object"); 374 else 375 Perl_croak(aTHX_ "lobj is not of type version"); 376 XSRETURN_EMPTY; 377} 378 379static 380void 381S_version_check_key(pTHX_ CV * cv, const char * key, int keylen) 382{ 383 dXSARGS; 384 if (items != 1) 385 croak_xs_usage(cv, "lobj"); 386 { 387 SV *lobj = POPs; 388 SV *ret; 389 VTYPECHECK(lobj, lobj, "lobj"); 390 if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) ) 391 ret = &PL_sv_yes; 392 else 393 ret = &PL_sv_no; 394 PUSHs(ret); 395 PUTBACK; 396 return; 397 } 398} 399 400VXS(version_is_alpha) 401{ 402 S_version_check_key(aTHX_ cv, "alpha", 5); 403} 404 405VXS(version_qv) 406{ 407 dXSARGS; 408 PERL_UNUSED_ARG(cv); 409 SP -= items; 410 { 411 SV * ver = ST(0); 412 SV * sv0 = ver; 413 SV * rv; 414 STRLEN len = 0; 415 const char * classname = ""; 416 U32 flags = 0; 417 if ( items == 2 ) { 418 SV * sv1 = ST(1); 419 SvGETMAGIC(sv1); 420 if (SvOK(sv1)) { 421 ver = sv1; 422 } 423 else { 424 Perl_croak(aTHX_ "Invalid version format (version required)"); 425 } 426 if ( sv_isobject(sv0) ) { /* class called as an object method */ 427 const HV * stash = SvSTASH(SvRV(sv0)); 428 classname = HvNAME_get(stash); 429 len = HvNAMELEN_get(stash); 430#ifdef HvNAMEUTF8 431 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; 432#endif 433 } 434 else { 435 classname = SvPV(sv0, len); 436 flags = SvUTF8(sv0); 437 } 438 } 439 if ( !SvVOK(ver) ) { /* not already a v-string */ 440 rv = sv_newmortal(); 441 SvSetSV_nosteal(rv,ver); /* make a duplicate */ 442 UPG_VERSION(rv, TRUE); 443 } else { 444 rv = sv_2mortal(NEW_VERSION(ver)); 445 } 446 if ( items == 2 && (len != 7 447 || strcmp(classname,"version")) ) { /* inherited new() */ 448#if PERL_VERSION == 5 449 sv_bless(rv, gv_stashpv((char *)classname, GV_ADD)); 450#else 451 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); 452#endif 453 } 454 PUSHs(rv); 455 } 456 PUTBACK; 457 return; 458} 459 460 461VXS(version_is_qv) 462{ 463 S_version_check_key(aTHX_ cv, "qv", 2); 464} 465 466#endif 467