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 Perl_croak(aTHX_ 137 "%" HEKf " does not define $%" HEKf 138 "::VERSION--version check failed", 139 HEKfARG(name), HEKfARG(name)); 140 } 141 else { 142#if PERL_VERSION_GE(5,8,0) 143 Perl_croak(aTHX_ 144 "%" SVf " defines neither package nor VERSION--" 145 "version check failed", 146 (void*)(ST(0)) ); 147#else 148 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", 149 SvPVx_nolen_const(ST(0)), 150 SvPVx_nolen_const(ST(0)) ); 151#endif 152 } 153 } 154 155 if ( ! ISA_VERSION_OBJ(req) ) { 156 /* req may very well be R/O, so create a new object */ 157 req = sv_2mortal( NEW_VERSION(req) ); 158 } 159 160 if ( VCMP( req, sv ) > 0 ) { 161 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { 162 req = VNORMAL(req); 163 sv = VNORMAL(sv); 164 } 165 else { 166 req = VSTRINGIFY(req); 167 sv = VSTRINGIFY(sv); 168 } 169 Perl_croak(aTHX_ "%" HEKf " version %" SVf " required--" 170 "this is only version %" SVf, HEKfARG(HvNAME_HEK(pkg)), 171 SVfARG(sv_2mortal(req)), 172 SVfARG(sv_2mortal(sv))); 173 } 174 } 175 176 /* if the package's $VERSION is not undef, it is upgraded to be a version object */ 177 if (ISA_VERSION_OBJ(sv)) { 178 ST(0) = sv_2mortal(VSTRINGIFY(sv)); 179 } else { 180 ST(0) = sv; 181 } 182 183 XSRETURN(1); 184} 185 186VXS(version_new) 187{ 188 dXSARGS; 189 SV *vs; 190 SV *rv; 191 const char * classname = ""; 192 STRLEN len; 193 U32 flags = 0; 194 SV * svarg0 = NULL; 195 PERL_UNUSED_VAR(cv); 196 197 SP -= items; 198 199 switch((U32)items) { 200 case 3: { 201 SV * svarg2; 202 vs = sv_newmortal(); 203 svarg2 = ST(2); 204 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2)); 205 break; 206 } 207 case 2: 208 vs = ST(1); 209 /* Just in case this is something like a tied hash */ 210 SvGETMAGIC(vs); 211 if(SvOK(vs)) 212 break; 213 /* fall through */ 214 case 1: 215 /* no param or explicit undef */ 216 /* create empty object */ 217 vs = sv_newmortal(); 218 sv_setpvs(vs,"undef"); 219 break; 220 default: 221 case 0: 222 Perl_croak_nocontext("Usage: version::new(class, version)"); 223 } 224 225 svarg0 = ST(0); 226 if ( sv_isobject(svarg0) ) { 227 /* get the class if called as an object method */ 228 const HV * stash = SvSTASH(SvRV(svarg0)); 229 classname = HvNAME_get(stash); 230 len = HvNAMELEN_get(stash); 231#ifdef HvNAMEUTF8 232 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; 233#endif 234 } 235 else { 236 classname = SvPV_nomg(svarg0, len); 237 flags = SvUTF8(svarg0); 238 } 239 240 rv = NEW_VERSION(vs); 241 if ( len != sizeof(VXS_CLASS)-1 242 || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */ 243 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); 244 245 VXS_RETURN_M_SV(rv); 246} 247 248#define VTYPECHECK(var, val, varname) \ 249 STMT_START { \ 250 SV * sv_vtc = val; \ 251 if (ISA_VERSION_OBJ(sv_vtc)) { \ 252 (var) = SvRV(sv_vtc); \ 253 } \ 254 else \ 255 Perl_croak_nocontext(varname " is not of type version"); \ 256 } STMT_END 257 258VXS(version_stringify) 259{ 260 dXSARGS; 261 if (items < 1) 262 croak_xs_usage(cv, "lobj, ..."); 263 SP -= items; 264 { 265 SV * lobj; 266 VTYPECHECK(lobj, ST(0), "lobj"); 267 268 VXS_RETURN_M_SV(VSTRINGIFY(lobj)); 269 } 270} 271 272VXS(version_numify) 273{ 274 dXSARGS; 275 if (items < 1) 276 croak_xs_usage(cv, "lobj, ..."); 277 SP -= items; 278 { 279 SV * lobj; 280 VTYPECHECK(lobj, ST(0), "lobj"); 281 VXS_RETURN_M_SV(VNUMIFY(lobj)); 282 } 283} 284 285VXS(version_normal) 286{ 287 dXSARGS; 288 if (items != 1) 289 croak_xs_usage(cv, "ver"); 290 SP -= items; 291 { 292 SV * ver; 293 VTYPECHECK(ver, ST(0), "ver"); 294 295 VXS_RETURN_M_SV(VNORMAL(ver)); 296 } 297} 298 299VXS(version_vcmp) 300{ 301 dXSARGS; 302 if (items < 2) 303 croak_xs_usage(cv, "lobj, robj, ..."); 304 SP -= items; 305 { 306 SV * lobj; 307 VTYPECHECK(lobj, ST(0), "lobj"); 308 { 309 SV *rs; 310 SV *rvs; 311 SV * robj = ST(1); 312 const int swap = items > 2 ? SvTRUE(ST(2)) : 0; 313 314 if ( !ISA_VERSION_OBJ(robj) ) 315 { 316 robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP))); 317 } 318 rvs = SvRV(robj); 319 320 if ( swap ) 321 { 322 rs = newSViv(VCMP(rvs,lobj)); 323 } 324 else 325 { 326 rs = newSViv(VCMP(lobj,rvs)); 327 } 328 329 VXS_RETURN_M_SV(rs); 330 } 331 } 332} 333 334VXS(version_boolean) 335{ 336 dXSARGS; 337 SV *lobj; 338 if (items < 1) 339 croak_xs_usage(cv, "lobj, ..."); 340 SP -= items; 341 VTYPECHECK(lobj, ST(0), "lobj"); 342 { 343 SV * const rs = 344 newSViv( VCMP(lobj, 345 sv_2mortal(NEW_VERSION( 346 sv_2mortal(newSVpvs("0")) 347 )) 348 ) 349 ); 350 VXS_RETURN_M_SV(rs); 351 } 352} 353 354VXS(version_noop) 355{ 356 dXSARGS; 357 if (items < 1) 358 croak_xs_usage(cv, "lobj, ..."); 359 if (ISA_VERSION_OBJ(ST(0))) 360 Perl_croak(aTHX_ "operation not supported with version object"); 361 else 362 Perl_croak(aTHX_ "lobj is not of type version"); 363 XSRETURN_EMPTY; 364} 365 366static 367void 368S_version_check_key(pTHX_ CV * cv, const char * key, int keylen) 369{ 370 dXSARGS; 371 if (items != 1) 372 croak_xs_usage(cv, "lobj"); 373 { 374 SV *lobj = POPs; 375 SV *ret; 376 VTYPECHECK(lobj, lobj, "lobj"); 377 if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) ) 378 ret = &PL_sv_yes; 379 else 380 ret = &PL_sv_no; 381 PUSHs(ret); 382 PUTBACK; 383 return; 384 } 385} 386 387VXS(version_is_alpha) 388{ 389 S_version_check_key(aTHX_ cv, "alpha", 5); 390} 391 392VXS(version_qv) 393{ 394 dXSARGS; 395 PERL_UNUSED_ARG(cv); 396 SP -= items; 397 { 398 SV * ver = ST(0); 399 SV * sv0 = ver; 400 SV * rv; 401 STRLEN len = 0; 402 const char * classname = ""; 403 U32 flags = 0; 404 if ( items == 2 ) { 405 SV * sv1 = ST(1); 406 SvGETMAGIC(sv1); 407 if (SvOK(sv1)) { 408 ver = sv1; 409 } 410 else { 411 Perl_croak(aTHX_ "Invalid version format (version required)"); 412 } 413 if ( sv_isobject(sv0) ) { /* class called as an object method */ 414 const HV * stash = SvSTASH(SvRV(sv0)); 415 classname = HvNAME_get(stash); 416 len = HvNAMELEN_get(stash); 417#ifdef HvNAMEUTF8 418 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; 419#endif 420 } 421 else { 422 classname = SvPV(sv0, len); 423 flags = SvUTF8(sv0); 424 } 425 } 426 if ( !SvVOK(ver) ) { /* not already a v-string */ 427 rv = sv_newmortal(); 428 SvSetSV_nosteal(rv,ver); /* make a duplicate */ 429 UPG_VERSION(rv, TRUE); 430 } else { 431 rv = sv_2mortal(NEW_VERSION(ver)); 432 } 433 if ( items == 2 && (len != 7 434 || strcmp(classname,"version")) ) { /* inherited new() */ 435 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); 436 } 437 PUSHs(rv); 438 } 439 PUTBACK; 440 return; 441} 442 443 444VXS(version_is_qv) 445{ 446 S_version_check_key(aTHX_ cv, "qv", 2); 447} 448 449#endif 450