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