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 # include "vutil.h" 6 #endif 7 8 #define VERSION_MAX 0x7FFFFFFF 9 10 /* 11 =for apidoc prescan_version 12 13 Validate that a given string can be parsed as a version object, but doesn't 14 actually perform the parsing. Can use either strict or lax validation rules. 15 Can optionally set a number of hint variables to save the parsing code 16 some time when tokenizing. 17 18 =cut 19 */ 20 const char * 21 #ifdef VUTIL_REPLACE_CORE 22 Perl_prescan_version2(pTHX_ const char *s, bool strict, 23 #else 24 Perl_prescan_version(pTHX_ const char *s, bool strict, 25 #endif 26 const char **errstr, 27 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { 28 bool qv = (sqv ? *sqv : FALSE); 29 int width = 3; 30 int saw_decimal = 0; 31 bool alpha = FALSE; 32 const char *d = s; 33 34 PERL_ARGS_ASSERT_PRESCAN_VERSION; 35 PERL_UNUSED_CONTEXT; 36 37 if (qv && isDIGIT(*d)) 38 goto dotted_decimal_version; 39 40 if (*d == 'v') { /* explicit v-string */ 41 d++; 42 if (isDIGIT(*d)) { 43 qv = TRUE; 44 } 45 else { /* degenerate v-string */ 46 /* requires v1.2.3 */ 47 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); 48 } 49 50 dotted_decimal_version: 51 if (strict && d[0] == '0' && isDIGIT(d[1])) { 52 /* no leading zeros allowed */ 53 BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); 54 } 55 56 while (isDIGIT(*d)) /* integer part */ 57 d++; 58 59 if (*d == '.') 60 { 61 saw_decimal++; 62 d++; /* decimal point */ 63 } 64 else 65 { 66 if (strict) { 67 /* require v1.2.3 */ 68 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); 69 } 70 else { 71 goto version_prescan_finish; 72 } 73 } 74 75 { 76 int i = 0; 77 int j = 0; 78 while (isDIGIT(*d)) { /* just keep reading */ 79 i++; 80 while (isDIGIT(*d)) { 81 d++; j++; 82 /* maximum 3 digits between decimal */ 83 if (strict && j > 3) { 84 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); 85 } 86 } 87 if (*d == '_') { 88 if (strict) { 89 BADVERSION(s,errstr,"Invalid version format (no underscores)"); 90 } 91 if ( alpha ) { 92 BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); 93 } 94 d++; 95 alpha = TRUE; 96 } 97 else if (*d == '.') { 98 if (alpha) { 99 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); 100 } 101 saw_decimal++; 102 d++; 103 } 104 else if (!isDIGIT(*d)) { 105 break; 106 } 107 j = 0; 108 } 109 110 if (strict && i < 2) { 111 /* requires v1.2.3 */ 112 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); 113 } 114 } 115 } /* end if dotted-decimal */ 116 else 117 { /* decimal versions */ 118 int j = 0; /* may need this later */ 119 /* special strict case for leading '.' or '0' */ 120 if (strict) { 121 if (*d == '.') { 122 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); 123 } 124 if (*d == '0' && isDIGIT(d[1])) { 125 BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); 126 } 127 } 128 129 /* and we never support negative versions */ 130 if ( *d == '-') { 131 BADVERSION(s,errstr,"Invalid version format (negative version number)"); 132 } 133 134 /* consume all of the integer part */ 135 while (isDIGIT(*d)) 136 d++; 137 138 /* look for a fractional part */ 139 if (*d == '.') { 140 /* we found it, so consume it */ 141 saw_decimal++; 142 d++; 143 } 144 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { 145 if ( d == s ) { 146 /* found nothing */ 147 BADVERSION(s,errstr,"Invalid version format (version required)"); 148 } 149 /* found just an integer */ 150 goto version_prescan_finish; 151 } 152 else if ( d == s ) { 153 /* didn't find either integer or period */ 154 BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); 155 } 156 else if (*d == '_') { 157 /* underscore can't come after integer part */ 158 if (strict) { 159 BADVERSION(s,errstr,"Invalid version format (no underscores)"); 160 } 161 else if (isDIGIT(d[1])) { 162 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); 163 } 164 else { 165 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); 166 } 167 } 168 else { 169 /* anything else after integer part is just invalid data */ 170 BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); 171 } 172 173 /* scan the fractional part after the decimal point*/ 174 175 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) { 176 /* strict or lax-but-not-the-end */ 177 BADVERSION(s,errstr,"Invalid version format (fractional part required)"); 178 } 179 180 while (isDIGIT(*d)) { 181 d++; j++; 182 if (*d == '.' && isDIGIT(d[-1])) { 183 if (alpha) { 184 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); 185 } 186 if (strict) { 187 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); 188 } 189 d = (char *)s; /* start all over again */ 190 qv = TRUE; 191 goto dotted_decimal_version; 192 } 193 if (*d == '_') { 194 if (strict) { 195 BADVERSION(s,errstr,"Invalid version format (no underscores)"); 196 } 197 if ( alpha ) { 198 BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); 199 } 200 if ( ! isDIGIT(d[1]) ) { 201 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); 202 } 203 width = j; 204 d++; 205 alpha = TRUE; 206 } 207 } 208 } 209 210 version_prescan_finish: 211 while (isSPACE(*d)) 212 d++; 213 214 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { 215 /* trailing non-numeric data */ 216 BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); 217 } 218 if (saw_decimal > 1 && d[-1] == '.') { 219 /* no trailing period allowed */ 220 BADVERSION(s,errstr,"Invalid version format (trailing decimal)"); 221 } 222 223 224 if (sqv) 225 *sqv = qv; 226 if (swidth) 227 *swidth = width; 228 if (ssaw_decimal) 229 *ssaw_decimal = saw_decimal; 230 if (salpha) 231 *salpha = alpha; 232 return d; 233 } 234 235 /* 236 =for apidoc scan_version 237 238 Returns a pointer to the next character after the parsed 239 version string, as well as upgrading the passed in SV to 240 an RV. 241 242 Function must be called with an already existing SV like 243 244 sv = newSV(0); 245 s = scan_version(s, SV *sv, bool qv); 246 247 Performs some preprocessing to the string to ensure that 248 it has the correct characteristics of a version. Flags the 249 object if it contains an underscore (which denotes this 250 is an alpha version). The boolean qv denotes that the version 251 should be interpreted as if it had multiple decimals, even if 252 it doesn't. 253 254 =cut 255 */ 256 257 const char * 258 #ifdef VUTIL_REPLACE_CORE 259 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv) 260 #else 261 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) 262 #endif 263 { 264 const char *start = s; 265 const char *pos; 266 const char *last; 267 const char *errstr = NULL; 268 int saw_decimal = 0; 269 int width = 3; 270 bool alpha = FALSE; 271 bool vinf = FALSE; 272 AV * av; 273 SV * hv; 274 275 PERL_ARGS_ASSERT_SCAN_VERSION; 276 277 while (isSPACE(*s)) /* leading whitespace is OK */ 278 s++; 279 280 last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); 281 if (errstr) { 282 /* "undef" is a special case and not an error */ 283 if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) { 284 Perl_croak(aTHX_ "%s", errstr); 285 } 286 } 287 288 start = s; 289 if (*s == 'v') 290 s++; 291 pos = s; 292 293 /* Now that we are through the prescan, start creating the object */ 294 av = newAV(); 295 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ 296 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ 297 298 #ifndef NODEFAULT_SHAREKEYS 299 HvSHAREKEYS_on(hv); /* key-sharing on by default */ 300 #endif 301 302 if ( qv ) 303 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); 304 if ( alpha ) 305 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); 306 if ( !qv && width < 3 ) 307 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); 308 309 while (isDIGIT(*pos) || *pos == '_') 310 pos++; 311 if (!isALPHA(*pos)) { 312 I32 rev; 313 314 for (;;) { 315 rev = 0; 316 { 317 /* this is atoi() that delimits on underscores */ 318 const char *end = pos; 319 I32 mult = 1; 320 I32 orev; 321 322 /* the following if() will only be true after the decimal 323 * point of a version originally created with a bare 324 * floating point number, i.e. not quoted in any way 325 */ 326 if ( !qv && s > start && saw_decimal == 1 ) { 327 mult *= 100; 328 while ( s < end ) { 329 if (*s == '_') 330 continue; 331 orev = rev; 332 rev += (*s - '0') * mult; 333 mult /= 10; 334 if ( (PERL_ABS(orev) > PERL_ABS(rev)) 335 || (PERL_ABS(rev) > VERSION_MAX )) { 336 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 337 "Integer overflow in version %d",VERSION_MAX); 338 s = end - 1; 339 rev = VERSION_MAX; 340 vinf = 1; 341 } 342 s++; 343 if ( *s == '_' ) 344 s++; 345 } 346 } 347 else { 348 while (--end >= s) { 349 int i; 350 if (*end == '_') 351 continue; 352 i = (*end - '0'); 353 if ( (mult == VERSION_MAX) 354 || (i > VERSION_MAX / mult) 355 || (i * mult > VERSION_MAX - rev)) 356 { 357 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 358 "Integer overflow in version"); 359 end = s - 1; 360 rev = VERSION_MAX; 361 vinf = 1; 362 } 363 else 364 rev += i * mult; 365 366 if (mult > VERSION_MAX / 10) 367 mult = VERSION_MAX; 368 else 369 mult *= 10; 370 } 371 } 372 } 373 374 /* Append revision */ 375 av_push(av, newSViv(rev)); 376 if ( vinf ) { 377 s = last; 378 break; 379 } 380 else if ( *pos == '.' ) { 381 pos++; 382 if (qv) { 383 while (*pos == '0') 384 ++pos; 385 } 386 s = pos; 387 } 388 else if ( *pos == '_' && isDIGIT(pos[1]) ) 389 s = ++pos; 390 else if ( *pos == ',' && isDIGIT(pos[1]) ) 391 s = ++pos; 392 else if ( isDIGIT(*pos) ) 393 s = pos; 394 else { 395 s = pos; 396 break; 397 } 398 if ( qv ) { 399 while ( isDIGIT(*pos) || *pos == '_') 400 pos++; 401 } 402 else { 403 int digits = 0; 404 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { 405 if ( *pos != '_' ) 406 digits++; 407 pos++; 408 } 409 } 410 } 411 } 412 if ( qv ) { /* quoted versions always get at least three terms*/ 413 SSize_t len = AvFILLp(av); 414 /* This for loop appears to trigger a compiler bug on OS X, as it 415 loops infinitely. Yes, len is negative. No, it makes no sense. 416 Compiler in question is: 417 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) 418 for ( len = 2 - len; len > 0; len-- ) 419 av_push(MUTABLE_AV(sv), newSViv(0)); 420 */ 421 len = 2 - len; 422 while (len-- > 0) 423 av_push(av, newSViv(0)); 424 } 425 426 /* need to save off the current version string for later */ 427 if ( vinf ) { 428 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); 429 (void)hv_stores(MUTABLE_HV(hv), "original", orig); 430 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); 431 } 432 else if ( s > start ) { 433 SV * orig = newSVpvn(start,s-start); 434 if ( qv && saw_decimal == 1 && *start != 'v' ) { 435 /* need to insert a v to be consistent */ 436 sv_insert(orig, 0, 0, "v", 1); 437 } 438 (void)hv_stores(MUTABLE_HV(hv), "original", orig); 439 } 440 else { 441 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); 442 av_push(av, newSViv(0)); 443 } 444 445 /* And finally, store the AV in the hash */ 446 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); 447 448 /* fix RT#19517 - special case 'undef' as string */ 449 if ( *s == 'u' && strEQ(s+1,"ndef") ) { 450 s += 5; 451 } 452 453 return s; 454 } 455 456 /* 457 =for apidoc new_version 458 459 Returns a new version object based on the passed in SV: 460 461 SV *sv = new_version(SV *ver); 462 463 Does not alter the passed in ver SV. See "upg_version" if you 464 want to upgrade the SV. 465 466 =cut 467 */ 468 469 SV * 470 #ifdef VUTIL_REPLACE_CORE 471 Perl_new_version2(pTHX_ SV *ver) 472 #else 473 Perl_new_version(pTHX_ SV *ver) 474 #endif 475 { 476 SV * const rv = newSV(0); 477 PERL_ARGS_ASSERT_NEW_VERSION; 478 if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */ 479 { 480 SSize_t key; 481 AV * const av = newAV(); 482 AV *sav; 483 /* This will get reblessed later if a derived class*/ 484 SV * const hv = newSVrv(rv, "version"); 485 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ 486 #ifndef NODEFAULT_SHAREKEYS 487 HvSHAREKEYS_on(hv); /* key-sharing on by default */ 488 #endif 489 490 if ( SvROK(ver) ) 491 ver = SvRV(ver); 492 493 /* Begin copying all of the elements */ 494 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) 495 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); 496 497 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) 498 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); 499 { 500 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE); 501 if(svp) { 502 const I32 width = SvIV(*svp); 503 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); 504 } 505 } 506 { 507 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE); 508 if(svp) 509 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp)); 510 } 511 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); 512 /* This will get reblessed later if a derived class*/ 513 for ( key = 0; key <= av_len(sav); key++ ) 514 { 515 SV * const sv = *av_fetch(sav, key, FALSE); 516 const I32 rev = SvIV(sv); 517 av_push(av, newSViv(rev)); 518 } 519 520 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); 521 return rv; 522 } 523 #ifdef SvVOK 524 { 525 const MAGIC* const mg = SvVSTRING_mg(ver); 526 if ( mg ) { /* already a v-string */ 527 const STRLEN len = mg->mg_len; 528 const char * const version = (const char*)mg->mg_ptr; 529 char *raw, *under; 530 static const char underscore[] = "_"; 531 sv_setpvn(rv,version,len); 532 raw = SvPV_nolen(rv); 533 under = ninstr(raw, raw+len, underscore, underscore + 1); 534 if (under) { 535 Move(under + 1, under, raw + len - under - 1, char); 536 SvCUR(rv)--; 537 *SvEND(rv) = '\0'; 538 } 539 /* this is for consistency with the pure Perl class */ 540 if ( isDIGIT(*version) ) 541 sv_insert(rv, 0, 0, "v", 1); 542 } 543 else { 544 #endif 545 SvSetSV_nosteal(rv, ver); /* make a duplicate */ 546 #ifdef SvVOK 547 } 548 } 549 #endif 550 sv_2mortal(rv); /* in case upg_version croaks before it returns */ 551 return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE)); 552 } 553 554 /* 555 =for apidoc upg_version 556 557 In-place upgrade of the supplied SV to a version object. 558 559 SV *sv = upg_version(SV *sv, bool qv); 560 561 Returns a pointer to the upgraded SV. Set the boolean qv if you want 562 to force this SV to be interpreted as an "extended" version. 563 564 =cut 565 */ 566 567 SV * 568 #ifdef VUTIL_REPLACE_CORE 569 Perl_upg_version2(pTHX_ SV *ver, bool qv) 570 #else 571 Perl_upg_version(pTHX_ SV *ver, bool qv) 572 #endif 573 { 574 const char *version, *s; 575 #ifdef SvVOK 576 const MAGIC *mg; 577 #endif 578 579 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) 580 ENTER; 581 #endif 582 PERL_ARGS_ASSERT_UPG_VERSION; 583 584 if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX) 585 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) { 586 /* out of bounds [unsigned] integer */ 587 STRLEN len; 588 char tbuf[64]; 589 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX); 590 version = savepvn(tbuf, len); 591 SAVEFREEPV(version); 592 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 593 "Integer overflow in version %d",VERSION_MAX); 594 } 595 else if ( SvUOK(ver) || SvIOK(ver)) 596 #if PERL_VERSION_LT(5,17,2) 597 VER_IV: 598 #endif 599 { 600 version = savesvpv(ver); 601 SAVEFREEPV(version); 602 } 603 else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) ) 604 #if PERL_VERSION_LT(5,17,2) 605 VER_NV: 606 #endif 607 { 608 STRLEN len; 609 610 /* may get too much accuracy */ 611 char tbuf[64]; 612 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; 613 char *buf; 614 615 #if PERL_VERSION_GE(5,19,0) 616 if (SvPOK(ver)) { 617 /* dualvar? */ 618 goto VER_PV; 619 } 620 #endif 621 622 #ifdef USE_LOCALE_NUMERIC 623 { 624 const char * const cur_numeric = setlocale(LC_NUMERIC, NULL); 625 assert(cur_numeric); 626 627 /* XS code can set the locale without us knowing. To protect the 628 * version number parsing, which requires the radix character to be a 629 * dot, update our records as to what the locale is, so that our 630 * existing macro mechanism can correctly change it to a dot and back 631 * if necessary. This code is extremely unlikely to be in a loop, so 632 * the extra work will have a negligible performance impact. See [perl 633 * #121930]. 634 * 635 * If the current locale is a standard one, but we are expecting it to 636 * be a different, underlying locale, update our records to make the 637 * underlying locale this (standard) one. If the current locale is not 638 * a standard one, we should be expecting a non-standard one, the same 639 * one that we have recorded as the underlying locale. If not, update 640 * our records. */ 641 if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) { 642 if (! PL_numeric_standard) { 643 new_numeric(cur_numeric); 644 } 645 } 646 else if (PL_numeric_standard 647 || ! PL_numeric_name 648 || strNE(PL_numeric_name, cur_numeric)) 649 { 650 new_numeric(cur_numeric); 651 } 652 } 653 #endif 654 { /* Braces needed because macro just below declares a variable */ 655 STORE_NUMERIC_LOCAL_SET_STANDARD(); 656 LOCK_NUMERIC_STANDARD(); 657 if (sv) { 658 Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver)); 659 len = SvCUR(sv); 660 buf = SvPVX(sv); 661 } 662 else { 663 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); 664 buf = tbuf; 665 } 666 UNLOCK_NUMERIC_STANDARD(); 667 RESTORE_NUMERIC_LOCAL(); 668 } 669 while (buf[len-1] == '0' && len > 0) len--; 670 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ 671 version = savepvn(buf, len); 672 SAVEFREEPV(version); 673 SvREFCNT_dec(sv); 674 } 675 #ifdef SvVOK 676 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ 677 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); 678 SAVEFREEPV(version); 679 qv = TRUE; 680 } 681 #endif 682 else if ( SvPOK(ver))/* must be a string or something like a string */ 683 VER_PV: 684 { 685 STRLEN len; 686 version = savepvn(SvPV(ver,len), SvCUR(ver)); 687 SAVEFREEPV(version); 688 #ifndef SvVOK 689 # if PERL_VERSION > 5 690 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ 691 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { 692 /* may be a v-string */ 693 char *testv = (char *)version; 694 STRLEN tlen = len; 695 for (tlen=0; tlen < len; tlen++, testv++) { 696 /* if one of the characters is non-text assume v-string */ 697 if (testv[0] < ' ') { 698 SV * const nsv = sv_newmortal(); 699 const char *nver; 700 const char *pos; 701 int saw_decimal = 0; 702 sv_setpvf(nsv,"v%vd",ver); 703 pos = nver = savepv(SvPV_nolen(nsv)); 704 SAVEFREEPV(pos); 705 706 /* scan the resulting formatted string */ 707 pos++; /* skip the leading 'v' */ 708 while ( *pos == '.' || isDIGIT(*pos) ) { 709 if ( *pos == '.' ) 710 saw_decimal++ ; 711 pos++; 712 } 713 714 /* is definitely a v-string */ 715 if ( saw_decimal >= 2 ) { 716 version = nver; 717 } 718 break; 719 } 720 } 721 } 722 # endif 723 #endif 724 } 725 #if PERL_VERSION_LT(5,17,2) 726 else if (SvIOKp(ver)) { 727 goto VER_IV; 728 } 729 else if (SvNOKp(ver)) { 730 goto VER_NV; 731 } 732 else if (SvPOKp(ver)) { 733 goto VER_PV; 734 } 735 #endif 736 else 737 { 738 /* no idea what this is */ 739 Perl_croak(aTHX_ "Invalid version format (non-numeric data)"); 740 } 741 742 s = SCAN_VERSION(version, ver, qv); 743 if ( *s != '\0' ) 744 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 745 "Version string '%s' contains invalid data; " 746 "ignoring: '%s'", version, s); 747 748 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) 749 LEAVE; 750 #endif 751 752 return ver; 753 } 754 755 /* 756 =for apidoc vverify 757 758 Validates that the SV contains valid internal structure for a version object. 759 It may be passed either the version object (RV) or the hash itself (HV). If 760 the structure is valid, it returns the HV. If the structure is invalid, 761 it returns NULL. 762 763 SV *hv = vverify(sv); 764 765 Note that it only confirms the bare minimum structure (so as not to get 766 confused by derived classes which may contain additional hash entries): 767 768 =over 4 769 770 =item * The SV is an HV or a reference to an HV 771 772 =item * The hash contains a "version" key 773 774 =item * The "version" key has a reference to an AV as its value 775 776 =back 777 778 =cut 779 */ 780 781 SV * 782 #ifdef VUTIL_REPLACE_CORE 783 Perl_vverify2(pTHX_ SV *vs) 784 #else 785 Perl_vverify(pTHX_ SV *vs) 786 #endif 787 { 788 SV *sv; 789 SV **svp; 790 791 PERL_ARGS_ASSERT_VVERIFY; 792 793 if ( SvROK(vs) ) 794 vs = SvRV(vs); 795 796 /* see if the appropriate elements exist */ 797 if ( SvTYPE(vs) == SVt_PVHV 798 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE)) 799 && (sv = SvRV(*svp)) 800 && SvTYPE(sv) == SVt_PVAV ) 801 return vs; 802 else 803 return NULL; 804 } 805 806 /* 807 =for apidoc vnumify 808 809 Accepts a version object and returns the normalized floating 810 point representation. Call like: 811 812 sv = vnumify(rv); 813 814 NOTE: you can pass either the object directly or the SV 815 contained within the RV. 816 817 The SV returned has a refcount of 1. 818 819 =cut 820 */ 821 822 SV * 823 #ifdef VUTIL_REPLACE_CORE 824 Perl_vnumify2(pTHX_ SV *vs) 825 #else 826 Perl_vnumify(pTHX_ SV *vs) 827 #endif 828 { 829 SSize_t i, len; 830 I32 digit; 831 bool alpha = FALSE; 832 SV *sv; 833 AV *av; 834 835 PERL_ARGS_ASSERT_VNUMIFY; 836 837 /* extract the HV from the object */ 838 vs = VVERIFY(vs); 839 if ( ! vs ) 840 Perl_croak(aTHX_ "Invalid version object"); 841 842 /* see if various flags exist */ 843 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) 844 alpha = TRUE; 845 846 if (alpha) { 847 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 848 "alpha->numify() is lossy"); 849 } 850 851 /* attempt to retrieve the version array */ 852 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { 853 return newSVpvs("0"); 854 } 855 856 len = av_len(av); 857 if ( len == -1 ) 858 { 859 return newSVpvs("0"); 860 } 861 862 { 863 SV * tsv = *av_fetch(av, 0, 0); 864 digit = SvIV(tsv); 865 } 866 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); 867 for ( i = 1 ; i <= len ; i++ ) 868 { 869 SV * tsv = *av_fetch(av, i, 0); 870 digit = SvIV(tsv); 871 Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit); 872 } 873 874 if ( len == 0 ) { 875 sv_catpvs(sv, "000"); 876 } 877 return sv; 878 } 879 880 /* 881 =for apidoc vnormal 882 883 Accepts a version object and returns the normalized string 884 representation. Call like: 885 886 sv = vnormal(rv); 887 888 NOTE: you can pass either the object directly or the SV 889 contained within the RV. 890 891 The SV returned has a refcount of 1. 892 893 =cut 894 */ 895 896 SV * 897 #ifdef VUTIL_REPLACE_CORE 898 Perl_vnormal2(pTHX_ SV *vs) 899 #else 900 Perl_vnormal(pTHX_ SV *vs) 901 #endif 902 { 903 I32 i, len, digit; 904 SV *sv; 905 AV *av; 906 907 PERL_ARGS_ASSERT_VNORMAL; 908 909 /* extract the HV from the object */ 910 vs = VVERIFY(vs); 911 if ( ! vs ) 912 Perl_croak(aTHX_ "Invalid version object"); 913 914 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); 915 916 len = av_len(av); 917 if ( len == -1 ) 918 { 919 return newSVpvs(""); 920 } 921 { 922 SV * tsv = *av_fetch(av, 0, 0); 923 digit = SvIV(tsv); 924 } 925 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); 926 for ( i = 1 ; i <= len ; i++ ) { 927 SV * tsv = *av_fetch(av, i, 0); 928 digit = SvIV(tsv); 929 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); 930 } 931 932 if ( len <= 2 ) { /* short version, must be at least three */ 933 for ( len = 2 - len; len != 0; len-- ) 934 sv_catpvs(sv,".0"); 935 } 936 return sv; 937 } 938 939 /* 940 =for apidoc vstringify 941 942 In order to maintain maximum compatibility with earlier versions 943 of Perl, this function will return either the floating point 944 notation or the multiple dotted notation, depending on whether 945 the original version contained 1 or more dots, respectively. 946 947 The SV returned has a refcount of 1. 948 949 =cut 950 */ 951 952 SV * 953 #ifdef VUTIL_REPLACE_CORE 954 Perl_vstringify2(pTHX_ SV *vs) 955 #else 956 Perl_vstringify(pTHX_ SV *vs) 957 #endif 958 { 959 SV ** svp; 960 PERL_ARGS_ASSERT_VSTRINGIFY; 961 962 /* extract the HV from the object */ 963 vs = VVERIFY(vs); 964 if ( ! vs ) 965 Perl_croak(aTHX_ "Invalid version object"); 966 967 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE); 968 if (svp) { 969 SV *pv; 970 pv = *svp; 971 if ( SvPOK(pv) ) 972 return newSVsv(pv); 973 else 974 return &PL_sv_undef; 975 } 976 else { 977 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) 978 return VNORMAL(vs); 979 else 980 return VNUMIFY(vs); 981 } 982 } 983 984 /* 985 =for apidoc vcmp 986 987 Version object aware cmp. Both operands must already have been 988 converted into version objects. 989 990 =cut 991 */ 992 993 int 994 #ifdef VUTIL_REPLACE_CORE 995 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv) 996 #else 997 Perl_vcmp(pTHX_ SV *lhv, SV *rhv) 998 #endif 999 { 1000 SSize_t i,l,m,r; 1001 I32 retval; 1002 I32 left = 0; 1003 I32 right = 0; 1004 AV *lav, *rav; 1005 1006 PERL_ARGS_ASSERT_VCMP; 1007 1008 /* extract the HVs from the objects */ 1009 lhv = VVERIFY(lhv); 1010 rhv = VVERIFY(rhv); 1011 if ( ! ( lhv && rhv ) ) 1012 Perl_croak(aTHX_ "Invalid version object"); 1013 1014 /* get the left hand term */ 1015 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); 1016 1017 /* and the right hand term */ 1018 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); 1019 1020 l = av_len(lav); 1021 r = av_len(rav); 1022 m = l < r ? l : r; 1023 retval = 0; 1024 i = 0; 1025 while ( i <= m && retval == 0 ) 1026 { 1027 SV * const lsv = *av_fetch(lav,i,0); 1028 SV * rsv; 1029 left = SvIV(lsv); 1030 rsv = *av_fetch(rav,i,0); 1031 right = SvIV(rsv); 1032 if ( left < right ) 1033 retval = -1; 1034 if ( left > right ) 1035 retval = +1; 1036 i++; 1037 } 1038 1039 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ 1040 { 1041 if ( l < r ) 1042 { 1043 while ( i <= r && retval == 0 ) 1044 { 1045 SV * const rsv = *av_fetch(rav,i,0); 1046 if ( SvIV(rsv) != 0 ) 1047 retval = -1; /* not a match after all */ 1048 i++; 1049 } 1050 } 1051 else 1052 { 1053 while ( i <= l && retval == 0 ) 1054 { 1055 SV * const lsv = *av_fetch(lav,i,0); 1056 if ( SvIV(lsv) != 0 ) 1057 retval = +1; /* not a match after all */ 1058 i++; 1059 } 1060 } 1061 } 1062 return retval; 1063 } 1064 1065 /* ex: set ro: */ 1066