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