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