vutil.c

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