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_set(rv, SvCUR(rv) - 1); 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 575 #ifdef dVAR 576 dVAR; 577 #endif 578 579 const char *version, *s; 580 #ifdef SvVOK 581 const MAGIC *mg; 582 #endif 583 584 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) 585 ENTER; 586 #endif 587 PERL_ARGS_ASSERT_UPG_VERSION; 588 589 if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX) 590 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) { 591 /* out of bounds [unsigned] integer */ 592 STRLEN len; 593 char tbuf[64]; 594 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX); 595 version = savepvn(tbuf, len); 596 SAVEFREEPV(version); 597 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 598 "Integer overflow in version %d",VERSION_MAX); 599 } 600 else if ( SvUOK(ver) || SvIOK(ver)) 601 #if PERL_VERSION_LT(5,17,2) 602 VER_IV: 603 #endif 604 { 605 version = savesvpv(ver); 606 SAVEFREEPV(version); 607 } 608 else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) ) 609 #if PERL_VERSION_LT(5,17,2) 610 VER_NV: 611 #endif 612 { 613 STRLEN len; 614 615 /* may get too much accuracy */ 616 char tbuf[64]; 617 #ifdef __vax__ 618 SV *sv = SvNVX(ver) > 10e37 ? newSV(64) : 0; 619 #else 620 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; 621 #endif 622 char *buf; 623 624 #if PERL_VERSION_GE(5,19,0) 625 if (SvPOK(ver)) { 626 /* dualvar? */ 627 goto VER_PV; 628 } 629 #endif 630 #ifdef USE_LOCALE_NUMERIC 631 632 { 633 /* This may or may not be called from code that has switched 634 * locales without letting perl know, therefore we have to find it 635 * from first principals. See [perl #121930]. */ 636 637 /* In windows, or not threaded, or not thread-safe, if it isn't C, 638 * set it to C. */ 639 640 # ifndef USE_POSIX_2008_LOCALE 641 642 const char * locale_name_on_entry; 643 644 LC_NUMERIC_LOCK(0); /* Start critical section */ 645 646 locale_name_on_entry = setlocale(LC_NUMERIC, NULL); 647 if ( strNE(locale_name_on_entry, "C") 648 && strNE(locale_name_on_entry, "POSIX")) 649 { 650 /* the setlocale() call might free or overwrite the name */ 651 locale_name_on_entry = savepv(locale_name_on_entry); 652 setlocale(LC_NUMERIC, "C"); 653 } 654 else { /* This value indicates to the restore code that we didn't 655 change the locale */ 656 locale_name_on_entry = NULL; 657 } 658 659 # else 660 661 const locale_t locale_obj_on_entry = uselocale((locale_t) 0); 662 const char * locale_name_on_entry = NULL; 663 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 664 665 if (locale_obj_on_entry == LC_GLOBAL_LOCALE) { 666 667 /* in the global locale, we can call system setlocale and if it 668 * isn't C, set it to C. */ 669 LC_NUMERIC_LOCK(0); 670 671 locale_name_on_entry = setlocale(LC_NUMERIC, NULL); 672 if ( strNE(locale_name_on_entry, "C") 673 && strNE(locale_name_on_entry, "POSIX")) 674 { 675 /* the setlocale() call might free or overwrite the name */ 676 locale_name_on_entry = savepv(locale_name_on_entry); 677 setlocale(LC_NUMERIC, "C"); 678 } 679 else { /* This value indicates to the restore code that we 680 didn't change the locale */ 681 locale_name_on_entry = NULL; 682 } 683 } 684 else if (locale_obj_on_entry == PL_underlying_numeric_obj) { 685 /* Here, the locale appears to have been changed to use the 686 * program's underlying locale. Just use our mechanisms to 687 * switch back to C. It might be possible for this pointer to 688 * actually refer to something else if it got released and 689 * reused somehow. But it doesn't matter, our mechanisms will 690 * work even so */ 691 STORE_LC_NUMERIC_SET_STANDARD(); 692 } 693 else if (locale_obj_on_entry != PL_C_locale_obj) { 694 /* The C object should be unchanged during a program's 695 * execution, so it should be safe to assume it means what it 696 * says, so if we are in it, no locale change is required. 697 * Otherwise, simply use the thread-safe operation. */ 698 uselocale(PL_C_locale_obj); 699 } 700 701 # endif 702 703 /* Prevent recursed calls from trying to change back */ 704 LOCK_LC_NUMERIC_STANDARD(); 705 706 #endif 707 708 if (sv) { 709 Perl_sv_catpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver)); 710 len = SvCUR(sv); 711 buf = SvPVX(sv); 712 } 713 else { 714 len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver)); 715 buf = tbuf; 716 } 717 718 #ifdef USE_LOCALE_NUMERIC 719 720 UNLOCK_LC_NUMERIC_STANDARD(); 721 722 # ifndef USE_POSIX_2008_LOCALE 723 724 if (locale_name_on_entry) { 725 setlocale(LC_NUMERIC, locale_name_on_entry); 726 Safefree(locale_name_on_entry); 727 } 728 729 LC_NUMERIC_UNLOCK; /* End critical section */ 730 731 # else 732 733 if (locale_name_on_entry) { 734 setlocale(LC_NUMERIC, locale_name_on_entry); 735 Safefree(locale_name_on_entry); 736 LC_NUMERIC_UNLOCK; 737 } 738 else if (locale_obj_on_entry == PL_underlying_numeric_obj) { 739 RESTORE_LC_NUMERIC(); 740 } 741 else if (locale_obj_on_entry != PL_C_locale_obj) { 742 uselocale(locale_obj_on_entry); 743 } 744 745 # endif 746 747 } 748 749 #endif /* USE_LOCALE_NUMERIC */ 750 751 while (buf[len-1] == '0' && len > 0) len--; 752 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ 753 version = savepvn(buf, len); 754 SAVEFREEPV(version); 755 SvREFCNT_dec(sv); 756 } 757 #ifdef SvVOK 758 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ 759 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); 760 SAVEFREEPV(version); 761 qv = TRUE; 762 } 763 #endif 764 else if ( SvPOK(ver))/* must be a string or something like a string */ 765 VER_PV: 766 { 767 STRLEN len; 768 version = savepvn(SvPV(ver,len), SvCUR(ver)); 769 SAVEFREEPV(version); 770 #ifndef SvVOK 771 # if PERL_VERSION > 5 772 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ 773 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { 774 /* may be a v-string */ 775 char *testv = (char *)version; 776 STRLEN tlen = len; 777 for (tlen=0; tlen < len; tlen++, testv++) { 778 /* if one of the characters is non-text assume v-string */ 779 if (testv[0] < ' ') { 780 SV * const nsv = sv_newmortal(); 781 const char *nver; 782 const char *pos; 783 int saw_decimal = 0; 784 sv_setpvf(nsv,"v%vd",ver); 785 pos = nver = savepv(SvPV_nolen(nsv)); 786 SAVEFREEPV(pos); 787 788 /* scan the resulting formatted string */ 789 pos++; /* skip the leading 'v' */ 790 while ( *pos == '.' || isDIGIT(*pos) ) { 791 if ( *pos == '.' ) 792 saw_decimal++ ; 793 pos++; 794 } 795 796 /* is definitely a v-string */ 797 if ( saw_decimal >= 2 ) { 798 version = nver; 799 } 800 break; 801 } 802 } 803 } 804 # endif 805 #endif 806 } 807 #if PERL_VERSION_LT(5,17,2) 808 else if (SvIOKp(ver)) { 809 goto VER_IV; 810 } 811 else if (SvNOKp(ver)) { 812 goto VER_NV; 813 } 814 else if (SvPOKp(ver)) { 815 goto VER_PV; 816 } 817 #endif 818 else 819 { 820 /* no idea what this is */ 821 Perl_croak(aTHX_ "Invalid version format (non-numeric data)"); 822 } 823 824 s = SCAN_VERSION(version, ver, qv); 825 if ( *s != '\0' ) 826 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 827 "Version string '%s' contains invalid data; " 828 "ignoring: '%s'", version, s); 829 830 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) 831 LEAVE; 832 #endif 833 834 return ver; 835 } 836 837 /* 838 =for apidoc vverify 839 840 Validates that the SV contains valid internal structure for a version object. 841 It may be passed either the version object (RV) or the hash itself (HV). If 842 the structure is valid, it returns the HV. If the structure is invalid, 843 it returns NULL. 844 845 SV *hv = vverify(sv); 846 847 Note that it only confirms the bare minimum structure (so as not to get 848 confused by derived classes which may contain additional hash entries): 849 850 =over 4 851 852 =item * The SV is an HV or a reference to an HV 853 854 =item * The hash contains a "version" key 855 856 =item * The "version" key has a reference to an AV as its value 857 858 =back 859 860 =cut 861 */ 862 863 SV * 864 #ifdef VUTIL_REPLACE_CORE 865 Perl_vverify2(pTHX_ SV *vs) 866 #else 867 Perl_vverify(pTHX_ SV *vs) 868 #endif 869 { 870 SV *sv; 871 SV **svp; 872 873 PERL_ARGS_ASSERT_VVERIFY; 874 875 if ( SvROK(vs) ) 876 vs = SvRV(vs); 877 878 /* see if the appropriate elements exist */ 879 if ( SvTYPE(vs) == SVt_PVHV 880 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE)) 881 && (sv = SvRV(*svp)) 882 && SvTYPE(sv) == SVt_PVAV ) 883 return vs; 884 else 885 return NULL; 886 } 887 888 /* 889 =for apidoc vnumify 890 891 Accepts a version object and returns the normalized floating 892 point representation. Call like: 893 894 sv = vnumify(rv); 895 896 NOTE: you can pass either the object directly or the SV 897 contained within the RV. 898 899 The SV returned has a refcount of 1. 900 901 =cut 902 */ 903 904 SV * 905 #ifdef VUTIL_REPLACE_CORE 906 Perl_vnumify2(pTHX_ SV *vs) 907 #else 908 Perl_vnumify(pTHX_ SV *vs) 909 #endif 910 { 911 SSize_t i, len; 912 I32 digit; 913 bool alpha = FALSE; 914 SV *sv; 915 AV *av; 916 917 PERL_ARGS_ASSERT_VNUMIFY; 918 919 /* extract the HV from the object */ 920 vs = VVERIFY(vs); 921 if ( ! vs ) 922 Perl_croak(aTHX_ "Invalid version object"); 923 924 /* see if various flags exist */ 925 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) 926 alpha = TRUE; 927 928 if (alpha) { 929 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 930 "alpha->numify() is lossy"); 931 } 932 933 /* attempt to retrieve the version array */ 934 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { 935 return newSVpvs("0"); 936 } 937 938 len = av_len(av); 939 if ( len == -1 ) 940 { 941 return newSVpvs("0"); 942 } 943 944 { 945 SV * tsv = *av_fetch(av, 0, 0); 946 digit = SvIV(tsv); 947 } 948 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); 949 for ( i = 1 ; i <= len ; i++ ) 950 { 951 SV * tsv = *av_fetch(av, i, 0); 952 digit = SvIV(tsv); 953 Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit); 954 } 955 956 if ( len == 0 ) { 957 sv_catpvs(sv, "000"); 958 } 959 return sv; 960 } 961 962 /* 963 =for apidoc vnormal 964 965 Accepts a version object and returns the normalized string 966 representation. Call like: 967 968 sv = vnormal(rv); 969 970 NOTE: you can pass either the object directly or the SV 971 contained within the RV. 972 973 The SV returned has a refcount of 1. 974 975 =cut 976 */ 977 978 SV * 979 #ifdef VUTIL_REPLACE_CORE 980 Perl_vnormal2(pTHX_ SV *vs) 981 #else 982 Perl_vnormal(pTHX_ SV *vs) 983 #endif 984 { 985 I32 i, len, digit; 986 SV *sv; 987 AV *av; 988 989 PERL_ARGS_ASSERT_VNORMAL; 990 991 /* extract the HV from the object */ 992 vs = VVERIFY(vs); 993 if ( ! vs ) 994 Perl_croak(aTHX_ "Invalid version object"); 995 996 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); 997 998 len = av_len(av); 999 if ( len == -1 ) 1000 { 1001 return newSVpvs(""); 1002 } 1003 { 1004 SV * tsv = *av_fetch(av, 0, 0); 1005 digit = SvIV(tsv); 1006 } 1007 sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit); 1008 for ( i = 1 ; i <= len ; i++ ) { 1009 SV * tsv = *av_fetch(av, i, 0); 1010 digit = SvIV(tsv); 1011 Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit); 1012 } 1013 1014 if ( len <= 2 ) { /* short version, must be at least three */ 1015 for ( len = 2 - len; len != 0; len-- ) 1016 sv_catpvs(sv,".0"); 1017 } 1018 return sv; 1019 } 1020 1021 /* 1022 =for apidoc vstringify 1023 1024 In order to maintain maximum compatibility with earlier versions 1025 of Perl, this function will return either the floating point 1026 notation or the multiple dotted notation, depending on whether 1027 the original version contained 1 or more dots, respectively. 1028 1029 The SV returned has a refcount of 1. 1030 1031 =cut 1032 */ 1033 1034 SV * 1035 #ifdef VUTIL_REPLACE_CORE 1036 Perl_vstringify2(pTHX_ SV *vs) 1037 #else 1038 Perl_vstringify(pTHX_ SV *vs) 1039 #endif 1040 { 1041 SV ** svp; 1042 PERL_ARGS_ASSERT_VSTRINGIFY; 1043 1044 /* extract the HV from the object */ 1045 vs = VVERIFY(vs); 1046 if ( ! vs ) 1047 Perl_croak(aTHX_ "Invalid version object"); 1048 1049 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE); 1050 if (svp) { 1051 SV *pv; 1052 pv = *svp; 1053 if ( SvPOK(pv) 1054 #if PERL_VERSION_LT(5,17,2) 1055 || SvPOKp(pv) 1056 #endif 1057 ) 1058 return newSVsv(pv); 1059 else 1060 return &PL_sv_undef; 1061 } 1062 else { 1063 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) 1064 return VNORMAL(vs); 1065 else 1066 return VNUMIFY(vs); 1067 } 1068 } 1069 1070 /* 1071 =for apidoc vcmp 1072 1073 Version object aware cmp. Both operands must already have been 1074 converted into version objects. 1075 1076 =cut 1077 */ 1078 1079 int 1080 #ifdef VUTIL_REPLACE_CORE 1081 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv) 1082 #else 1083 Perl_vcmp(pTHX_ SV *lhv, SV *rhv) 1084 #endif 1085 { 1086 SSize_t i,l,m,r; 1087 I32 retval; 1088 I32 left = 0; 1089 I32 right = 0; 1090 AV *lav, *rav; 1091 1092 PERL_ARGS_ASSERT_VCMP; 1093 1094 /* extract the HVs from the objects */ 1095 lhv = VVERIFY(lhv); 1096 rhv = VVERIFY(rhv); 1097 if ( ! ( lhv && rhv ) ) 1098 Perl_croak(aTHX_ "Invalid version object"); 1099 1100 /* get the left hand term */ 1101 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); 1102 1103 /* and the right hand term */ 1104 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); 1105 1106 l = av_len(lav); 1107 r = av_len(rav); 1108 m = l < r ? l : r; 1109 retval = 0; 1110 i = 0; 1111 while ( i <= m && retval == 0 ) 1112 { 1113 SV * const lsv = *av_fetch(lav,i,0); 1114 SV * rsv; 1115 left = SvIV(lsv); 1116 rsv = *av_fetch(rav,i,0); 1117 right = SvIV(rsv); 1118 if ( left < right ) 1119 retval = -1; 1120 if ( left > right ) 1121 retval = +1; 1122 i++; 1123 } 1124 1125 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ 1126 { 1127 if ( l < r ) 1128 { 1129 while ( i <= r && retval == 0 ) 1130 { 1131 SV * const rsv = *av_fetch(rav,i,0); 1132 if ( SvIV(rsv) != 0 ) 1133 retval = -1; /* not a match after all */ 1134 i++; 1135 } 1136 } 1137 else 1138 { 1139 while ( i <= l && retval == 0 ) 1140 { 1141 SV * const lsv = *av_fetch(lav,i,0); 1142 if ( SvIV(lsv) != 0 ) 1143 retval = +1; /* not a match after all */ 1144 i++; 1145 } 1146 } 1147 } 1148 return retval; 1149 } 1150 1151 /* ex: set ro: */ 1152