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 #ifdef __vax__ 660 SV *sv = SvNVX(ver) > 10e37 ? newSV(64) : 0; 661 #else 662 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; 663 #endif 664 char *buf; 665 666 #if PERL_VERSION_GE(5,19,0) 667 if (SvPOK(ver)) { 668 /* dualvar? */ 669 goto VER_PV; 670 } 671 #endif 672 673 { 674 675 #ifdef USE_POSIX_2008_LOCALE 676 677 /* With POSIX 2008, all we have to do is toggle to the C locale 678 * just long enough to get the value (which should have a dot). */ 679 const locale_t locale_obj_on_entry = uselocale(PL_C_locale_obj); 680 GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len); 681 uselocale(locale_obj_on_entry); 682 #else 683 /* Without POSIX 2008, it could be that toggling will zap another 684 * thread's locale. Avoid that if possible by looking at the NV and 685 * changing a non-dot radix into a dot */ 686 687 char * radix = NULL; 688 unsigned int radix_len = 0; 689 690 GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len); 691 692 # ifndef ARABIC_DECIMAL_SEPARATOR_UTF8 693 694 /* This becomes feasible since there are only very few possible 695 * radix characters in the world. khw knows of just 3 possible 696 * ones. If we are being compiled on a perl without the very rare 697 * third one, ARABIC DECIMAL SEPARATOR, just scan for the other 698 * two: FULL STOP (dot) and COMMA */ 699 radix = strpbrk(buf, ".,"); 700 if (LIKELY(radix)) { 701 radix_len = 1; 702 } 703 # else 704 /* Here, we have information about the third one; since it is 705 * multi-byte, it becomes a little more work. Scan for the dot, 706 * comma, or first byte of the arabic one */ 707 radix = strpbrk(buf, 708 ".," 709 ARABIC_DECIMAL_SEPARATOR_UTF8_FIRST_BYTE_s); 710 711 if (LIKELY(radix)) { 712 if (LIKELY( (* (U8 *) radix) 713 != ARABIC_DECIMAL_SEPARATOR_UTF8_FIRST_BYTE)) 714 { 715 radix_len = 1; /* Dot and comma are length 1 */ 716 } 717 else { 718 719 /* Make sure that the rest of the bytes are what we expect 720 * for the remainder of the arabic radix. If not, we 721 * didn't find the radix. */ 722 radix_len = STRLENs(ARABIC_DECIMAL_SEPARATOR_UTF8); 723 if ( radix + radix_len >= buf + len 724 || memNEs(radix + 1, 725 STRLENs(ARABIC_DECIMAL_SEPARATOR_UTF8_TAIL), 726 ARABIC_DECIMAL_SEPARATOR_UTF8_TAIL)) 727 { 728 radix = NULL; 729 radix_len = 0; 730 } 731 } 732 } 733 734 # endif 735 736 /* Now convert any found radix into a dot (if not already). This 737 * effectively does: ver =~ s/radix/dot/ */ 738 if (radix) { 739 if (*radix != '.') { 740 *radix = '.'; 741 742 if (radix_len > 1) { 743 Move(radix + radix_len, /* from what follows the radix 744 */ 745 radix + 1, /* to just after the new dot */ 746 747 /* the number of bytes remaining, plus the NUL 748 * */ 749 len - (radix - buf) - radix_len + 1, 750 char); 751 len -= radix_len - 1; 752 } 753 } 754 755 /* Guard against the very unlikely case that the radix is more 756 * than a single character, like ".."; that is, make sure the 757 * radix string we found above is the whole radix, and not just 758 * the prefix of a longer one. Success is indicated by it 759 * being at the end of the string, or the next byte should be a 760 * digit */ 761 if (radix < buf + len && ! inRANGE(radix[1], '0', '9')) { 762 radix = NULL; 763 radix_len = 0; 764 } 765 } 766 767 if (! radix) { 768 769 /* If we couldn't find what the radix is, or didn't find it in 770 * the PV, resort to toggling the locale to one known to have a 771 * dot radix. This may or may not be called from code that has 772 * switched locales without letting perl know, therefore we 773 * have to find it from first principals. See [perl #121930]. 774 * */ 775 776 # if ! defined(LC_NUMERIC) || ! defined(USE_LOCALE_NUMERIC) 777 778 Perl_croak(aTHX_ "panic: Unexpectedly didn't find a dot radix" 779 " character in '%s'", buf); 780 # else 781 const char * locale_name_on_entry = NULL; 782 783 /* In windows, or not threaded, or not thread-safe, if it isn't 784 * C, set it to C. */ 785 786 POSIX_SETLOCALE_LOCK; /* Start critical section */ 787 788 locale_name_on_entry = setlocale(LC_NUMERIC, NULL); 789 if ( strEQ(locale_name_on_entry, "C") 790 || strEQ(locale_name_on_entry, "C.UTF-8") 791 || strEQ(locale_name_on_entry, "POSIX")) 792 { 793 /* No need to change the locale, since these all are known 794 * to have a dot radix. Change the variable to indicate to 795 * the restore code that nothing needs to be done */ 796 locale_name_on_entry = NULL; 797 } 798 else { 799 /* The setlocale() call might free or overwrite the name */ 800 locale_name_on_entry = savepv(locale_name_on_entry); 801 setlocale(LC_NUMERIC, "C"); 802 } 803 804 GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len); 805 806 if (locale_name_on_entry) { 807 setlocale(LC_NUMERIC, locale_name_on_entry); 808 Safefree(locale_name_on_entry); 809 } 810 811 POSIX_SETLOCALE_UNLOCK; /* End critical section */ 812 # endif 813 } 814 #endif 815 } 816 817 /* Strip trailing zero's from the version number */ 818 while (buf[len-1] == '0' && len > 0) len--; 819 820 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ 821 822 version = savepvn(buf, len); 823 SAVEFREEPV(version); 824 SvREFCNT_dec(sv); 825 } 826 #ifdef SvVOK 827 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ 828 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); 829 SAVEFREEPV(version); 830 qv = TRUE; 831 } 832 #endif 833 else if ( SvPOK(ver))/* must be a string or something like a string */ 834 VER_PV: 835 { 836 STRLEN len; 837 version = savepvn(SvPV(ver,len), SvCUR(ver)); 838 SAVEFREEPV(version); 839 #ifndef SvVOK 840 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ 841 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { 842 /* may be a v-string */ 843 char *testv = (char *)version; 844 STRLEN tlen = len; 845 for (tlen=0; tlen < len; tlen++, testv++) { 846 /* if one of the characters is non-text assume v-string */ 847 if (testv[0] < ' ') { 848 SV * const nsv = sv_newmortal(); 849 const char *nver; 850 const char *pos; 851 int saw_decimal = 0; 852 sv_setpvf(nsv,"v%vd",ver); 853 pos = nver = savepv(SvPV_nolen(nsv)); 854 SAVEFREEPV(pos); 855 856 /* scan the resulting formatted string */ 857 pos++; /* skip the leading 'v' */ 858 while ( *pos == '.' || isDIGIT(*pos) ) { 859 if ( *pos == '.' ) 860 saw_decimal++ ; 861 pos++; 862 } 863 864 /* is definitely a v-string */ 865 if ( saw_decimal >= 2 ) { 866 version = nver; 867 } 868 break; 869 } 870 } 871 } 872 #endif 873 } 874 #if PERL_VERSION_LT(5,17,2) 875 else if (SvIOKp(ver)) { 876 goto VER_IV; 877 } 878 else if (SvNOKp(ver)) { 879 goto VER_NV; 880 } 881 else if (SvPOKp(ver)) { 882 goto VER_PV; 883 } 884 #endif 885 else 886 { 887 /* no idea what this is */ 888 Perl_croak(aTHX_ "Invalid version format (non-numeric data)"); 889 } 890 891 s = SCAN_VERSION(version, ver, qv); 892 if ( *s != '\0' ) 893 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 894 "Version string '%s' contains invalid data; " 895 "ignoring: '%s'", version, s); 896 897 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) 898 LEAVE; 899 #endif 900 901 return ver; 902 } 903 904 /* 905 =for apidoc vverify 906 907 Validates that the SV contains valid internal structure for a version object. 908 It may be passed either the version object (RV) or the hash itself (HV). If 909 the structure is valid, it returns the HV. If the structure is invalid, 910 it returns NULL. 911 912 SV *hv = vverify(sv); 913 914 Note that it only confirms the bare minimum structure (so as not to get 915 confused by derived classes which may contain additional hash entries): 916 917 =over 4 918 919 =item * The SV is an HV or a reference to an HV 920 921 =item * The hash contains a "version" key 922 923 =item * The "version" key has a reference to an AV as its value 924 925 =back 926 927 =cut 928 */ 929 930 SV * 931 #ifdef VUTIL_REPLACE_CORE 932 Perl_vverify2(pTHX_ SV *vs) 933 #else 934 Perl_vverify(pTHX_ SV *vs) 935 #endif 936 { 937 SV *sv; 938 SV **svp; 939 940 PERL_ARGS_ASSERT_VVERIFY; 941 942 if ( SvROK(vs) ) 943 vs = SvRV(vs); 944 945 /* see if the appropriate elements exist */ 946 if ( SvTYPE(vs) == SVt_PVHV 947 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE)) 948 && (sv = SvRV(*svp)) 949 && SvTYPE(sv) == SVt_PVAV ) 950 return vs; 951 else 952 return NULL; 953 } 954 955 /* 956 =for apidoc vnumify 957 958 Accepts a version object and returns the normalized floating 959 point representation. Call like: 960 961 sv = vnumify(rv); 962 963 NOTE: you can pass either the object directly or the SV 964 contained within the RV. 965 966 The SV returned has a refcount of 1. 967 968 =cut 969 */ 970 971 SV * 972 #ifdef VUTIL_REPLACE_CORE 973 Perl_vnumify2(pTHX_ SV *vs) 974 #else 975 Perl_vnumify(pTHX_ SV *vs) 976 #endif 977 { 978 SSize_t i, len; 979 I32 digit; 980 bool alpha = FALSE; 981 SV *sv; 982 AV *av; 983 984 PERL_ARGS_ASSERT_VNUMIFY; 985 986 /* extract the HV from the object */ 987 vs = VVERIFY(vs); 988 if ( ! vs ) 989 Perl_croak(aTHX_ "Invalid version object"); 990 991 /* see if various flags exist */ 992 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) 993 alpha = TRUE; 994 995 if (alpha) { 996 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 997 "alpha->numify() is lossy"); 998 } 999 1000 /* attempt to retrieve the version array */ 1001 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { 1002 return newSVpvs("0"); 1003 } 1004 1005 len = av_len(av); 1006 if ( len == -1 ) 1007 { 1008 return newSVpvs("0"); 1009 } 1010 1011 { 1012 SV * tsv = *av_fetch(av, 0, 0); 1013 digit = SvIV(tsv); 1014 } 1015 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); 1016 for ( i = 1 ; i <= len ; i++ ) 1017 { 1018 SV * tsv = *av_fetch(av, i, 0); 1019 digit = SvIV(tsv); 1020 Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit); 1021 } 1022 1023 if ( len == 0 ) { 1024 sv_catpvs(sv, "000"); 1025 } 1026 return sv; 1027 } 1028 1029 /* 1030 =for apidoc vnormal 1031 1032 Accepts a version object and returns the normalized string 1033 representation. Call like: 1034 1035 sv = vnormal(rv); 1036 1037 NOTE: you can pass either the object directly or the SV 1038 contained within the RV. 1039 1040 The SV returned has a refcount of 1. 1041 1042 =cut 1043 */ 1044 1045 SV * 1046 #ifdef VUTIL_REPLACE_CORE 1047 Perl_vnormal2(pTHX_ SV *vs) 1048 #else 1049 Perl_vnormal(pTHX_ SV *vs) 1050 #endif 1051 { 1052 I32 i, len, digit; 1053 SV *sv; 1054 AV *av; 1055 1056 PERL_ARGS_ASSERT_VNORMAL; 1057 1058 /* extract the HV from the object */ 1059 vs = VVERIFY(vs); 1060 if ( ! vs ) 1061 Perl_croak(aTHX_ "Invalid version object"); 1062 1063 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); 1064 1065 len = av_len(av); 1066 if ( len == -1 ) 1067 { 1068 return newSVpvs(""); 1069 } 1070 { 1071 SV * tsv = *av_fetch(av, 0, 0); 1072 digit = SvIV(tsv); 1073 } 1074 sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit); 1075 for ( i = 1 ; i <= len ; i++ ) { 1076 SV * tsv = *av_fetch(av, i, 0); 1077 digit = SvIV(tsv); 1078 Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit); 1079 } 1080 1081 if ( len <= 2 ) { /* short version, must be at least three */ 1082 for ( len = 2 - len; len != 0; len-- ) 1083 sv_catpvs(sv,".0"); 1084 } 1085 return sv; 1086 } 1087 1088 /* 1089 =for apidoc vstringify 1090 1091 In order to maintain maximum compatibility with earlier versions 1092 of Perl, this function will return either the floating point 1093 notation or the multiple dotted notation, depending on whether 1094 the original version contained 1 or more dots, respectively. 1095 1096 The SV returned has a refcount of 1. 1097 1098 =cut 1099 */ 1100 1101 SV * 1102 #ifdef VUTIL_REPLACE_CORE 1103 Perl_vstringify2(pTHX_ SV *vs) 1104 #else 1105 Perl_vstringify(pTHX_ SV *vs) 1106 #endif 1107 { 1108 SV ** svp; 1109 PERL_ARGS_ASSERT_VSTRINGIFY; 1110 1111 /* extract the HV from the object */ 1112 vs = VVERIFY(vs); 1113 if ( ! vs ) 1114 Perl_croak(aTHX_ "Invalid version object"); 1115 1116 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE); 1117 if (svp) { 1118 SV *pv; 1119 pv = *svp; 1120 if ( SvPOK(pv) 1121 #if PERL_VERSION_LT(5,17,2) 1122 || SvPOKp(pv) 1123 #endif 1124 ) 1125 return newSVsv(pv); 1126 else 1127 return &PL_sv_undef; 1128 } 1129 else { 1130 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) 1131 return VNORMAL(vs); 1132 else 1133 return VNUMIFY(vs); 1134 } 1135 } 1136 1137 /* 1138 =for apidoc vcmp 1139 1140 Version object aware cmp. Both operands must already have been 1141 converted into version objects. 1142 1143 =cut 1144 */ 1145 1146 int 1147 #ifdef VUTIL_REPLACE_CORE 1148 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv) 1149 #else 1150 Perl_vcmp(pTHX_ SV *lhv, SV *rhv) 1151 #endif 1152 { 1153 SSize_t i,l,m,r; 1154 I32 retval; 1155 I32 left = 0; 1156 I32 right = 0; 1157 AV *lav, *rav; 1158 1159 PERL_ARGS_ASSERT_VCMP; 1160 1161 /* extract the HVs from the objects */ 1162 lhv = VVERIFY(lhv); 1163 rhv = VVERIFY(rhv); 1164 if ( ! ( lhv && rhv ) ) 1165 Perl_croak(aTHX_ "Invalid version object"); 1166 1167 /* get the left hand term */ 1168 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); 1169 1170 /* and the right hand term */ 1171 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); 1172 1173 l = av_len(lav); 1174 r = av_len(rav); 1175 m = l < r ? l : r; 1176 retval = 0; 1177 i = 0; 1178 while ( i <= m && retval == 0 ) 1179 { 1180 SV * const lsv = *av_fetch(lav,i,0); 1181 SV * rsv; 1182 left = SvIV(lsv); 1183 rsv = *av_fetch(rav,i,0); 1184 right = SvIV(rsv); 1185 if ( left < right ) 1186 retval = -1; 1187 if ( left > right ) 1188 retval = +1; 1189 i++; 1190 } 1191 1192 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ 1193 { 1194 if ( l < r ) 1195 { 1196 while ( i <= r && retval == 0 ) 1197 { 1198 SV * const rsv = *av_fetch(rav,i,0); 1199 if ( SvIV(rsv) != 0 ) 1200 retval = -1; /* not a match after all */ 1201 i++; 1202 } 1203 } 1204 else 1205 { 1206 while ( i <= l && retval == 0 ) 1207 { 1208 SV * const lsv = *av_fetch(lav,i,0); 1209 if ( SvIV(lsv) != 0 ) 1210 retval = +1; /* not a match after all */ 1211 i++; 1212 } 1213 } 1214 } 1215 return retval; 1216 } 1217 1218 /* ex: set ro: */ 1219