add a small buffer to gv_stash_name
[perl.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_existss(MUTABLE_HV(ver), "qv") )
495             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
496
497         if ( hv_existss(MUTABLE_HV(ver), "alpha") )
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(rv)--;
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
622 #ifdef USE_LOCALE_NUMERIC
623         {
624             const char * const cur_numeric = setlocale(LC_NUMERIC, NULL);
625             assert(cur_numeric);
626
627             /* XS code can set the locale without us knowing.  To protect the
628              * version number parsing, which requires the radix character to be a
629              * dot, update our records as to what the locale is, so that our
630              * existing macro mechanism can correctly change it to a dot and back
631              * if necessary.  This code is extremely unlikely to be in a loop, so
632              * the extra work will have a negligible performance impact.  See [perl
633              * #121930].
634              *
635              * If the current locale is a standard one, but we are expecting it to
636              * be a different, underlying locale, update our records to make the
637              * underlying locale this (standard) one.  If the current locale is not
638              * a standard one, we should be expecting a non-standard one, the same
639              * one that we have recorded as the underlying locale.  If not, update
640              * our records. */
641             if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) {
642                 if (! PL_numeric_standard) {
643                     new_numeric(cur_numeric);
644                 }
645             }
646             else if (PL_numeric_standard
647                      || ! PL_numeric_name
648                      || strNE(PL_numeric_name, cur_numeric))
649             {
650                 new_numeric(cur_numeric);
651             }
652         }
653 #endif
654         { /* Braces needed because macro just below declares a variable */
655         STORE_NUMERIC_LOCAL_SET_STANDARD();
656         LOCK_NUMERIC_STANDARD();
657         if (sv) {
658             Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
659             len = SvCUR(sv);
660             buf = SvPVX(sv);
661         }
662         else {
663             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
664             buf = tbuf;
665         }
666         UNLOCK_NUMERIC_STANDARD();
667         RESTORE_NUMERIC_LOCAL();
668         }
669         while (buf[len-1] == '0' && len > 0) len--;
670         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
671         version = savepvn(buf, len);
672         SAVEFREEPV(version);
673         SvREFCNT_dec(sv);
674     }
675 #ifdef SvVOK
676     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
677         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
678         SAVEFREEPV(version);
679         qv = TRUE;
680     }
681 #endif
682     else if ( SvPOK(ver))/* must be a string or something like a string */
683 VER_PV:
684     {
685         STRLEN len;
686         version = savepvn(SvPV(ver,len), SvCUR(ver));
687         SAVEFREEPV(version);
688 #ifndef SvVOK
689 #  if PERL_VERSION > 5
690         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
691         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
692             /* may be a v-string */
693             char *testv = (char *)version;
694             STRLEN tlen = len;
695             for (tlen=0; tlen < len; tlen++, testv++) {
696                 /* if one of the characters is non-text assume v-string */
697                 if (testv[0] < ' ') {
698                     SV * const nsv = sv_newmortal();
699                     const char *nver;
700                     const char *pos;
701                     int saw_decimal = 0;
702                     sv_setpvf(nsv,"v%vd",ver);
703                     pos = nver = savepv(SvPV_nolen(nsv));
704                     SAVEFREEPV(pos);
705
706                     /* scan the resulting formatted string */
707                     pos++; /* skip the leading 'v' */
708                     while ( *pos == '.' || isDIGIT(*pos) ) {
709                         if ( *pos == '.' )
710                             saw_decimal++ ;
711                         pos++;
712                     }
713
714                     /* is definitely a v-string */
715                     if ( saw_decimal >= 2 ) {
716                         version = nver;
717                     }
718                     break;
719                 }
720             }
721         }
722 #  endif
723 #endif
724     }
725 #if PERL_VERSION_LT(5,17,2)
726     else if (SvIOKp(ver)) {
727         goto VER_IV;
728     }
729     else if (SvNOKp(ver)) {
730         goto VER_NV;
731     }
732     else if (SvPOKp(ver)) {
733         goto VER_PV;
734     }
735 #endif
736     else
737     {
738         /* no idea what this is */
739         Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
740     }
741
742     s = SCAN_VERSION(version, ver, qv);
743     if ( *s != '\0' ) 
744         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
745                        "Version string '%s' contains invalid data; "
746                        "ignoring: '%s'", version, s);
747
748 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
749     LEAVE;
750 #endif
751
752     return ver;
753 }
754
755 /*
756 =for apidoc vverify
757
758 Validates that the SV contains valid internal structure for a version object.
759 It may be passed either the version object (RV) or the hash itself (HV).  If
760 the structure is valid, it returns the HV.  If the structure is invalid,
761 it returns NULL.
762
763     SV *hv = vverify(sv);
764
765 Note that it only confirms the bare minimum structure (so as not to get
766 confused by derived classes which may contain additional hash entries):
767
768 =over 4
769
770 =item * The SV is an HV or a reference to an HV
771
772 =item * The hash contains a "version" key
773
774 =item * The "version" key has a reference to an AV as its value
775
776 =back
777
778 =cut
779 */
780
781 SV *
782 #ifdef VUTIL_REPLACE_CORE
783 Perl_vverify2(pTHX_ SV *vs)
784 #else
785 Perl_vverify(pTHX_ SV *vs)
786 #endif
787 {
788     SV *sv;
789     SV **svp;
790
791     PERL_ARGS_ASSERT_VVERIFY;
792
793     if ( SvROK(vs) )
794         vs = SvRV(vs);
795
796     /* see if the appropriate elements exist */
797     if ( SvTYPE(vs) == SVt_PVHV
798          && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
799          && (sv = SvRV(*svp))
800          && SvTYPE(sv) == SVt_PVAV )
801         return vs;
802     else
803         return NULL;
804 }
805
806 /*
807 =for apidoc vnumify
808
809 Accepts a version object and returns the normalized floating
810 point representation.  Call like:
811
812     sv = vnumify(rv);
813
814 NOTE: you can pass either the object directly or the SV
815 contained within the RV.
816
817 The SV returned has a refcount of 1.
818
819 =cut
820 */
821
822 SV *
823 #ifdef VUTIL_REPLACE_CORE
824 Perl_vnumify2(pTHX_ SV *vs)
825 #else
826 Perl_vnumify(pTHX_ SV *vs)
827 #endif
828 {
829     SSize_t i, len;
830     I32 digit;
831     bool alpha = FALSE;
832     SV *sv;
833     AV *av;
834
835     PERL_ARGS_ASSERT_VNUMIFY;
836
837     /* extract the HV from the object */
838     vs = VVERIFY(vs);
839     if ( ! vs )
840         Perl_croak(aTHX_ "Invalid version object");
841
842     /* see if various flags exist */
843     if ( hv_existss(MUTABLE_HV(vs), "alpha") )
844         alpha = TRUE;
845
846     if (alpha) {
847         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
848                        "alpha->numify() is lossy");
849     }
850
851     /* attempt to retrieve the version array */
852     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
853         return newSVpvs("0");
854     }
855
856     len = av_len(av);
857     if ( len == -1 )
858     {
859         return newSVpvs("0");
860     }
861
862     {
863         SV * tsv = *av_fetch(av, 0, 0);
864         digit = SvIV(tsv);
865     }
866     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
867     for ( i = 1 ; i <= len ; i++ )
868     {
869         SV * tsv = *av_fetch(av, i, 0);
870         digit = SvIV(tsv);
871         Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
872     }
873
874     if ( len == 0 ) {
875         sv_catpvs(sv, "000");
876     }
877     return sv;
878 }
879
880 /*
881 =for apidoc vnormal
882
883 Accepts a version object and returns the normalized string
884 representation.  Call like:
885
886     sv = vnormal(rv);
887
888 NOTE: you can pass either the object directly or the SV
889 contained within the RV.
890
891 The SV returned has a refcount of 1.
892
893 =cut
894 */
895
896 SV *
897 #ifdef VUTIL_REPLACE_CORE
898 Perl_vnormal2(pTHX_ SV *vs)
899 #else
900 Perl_vnormal(pTHX_ SV *vs)
901 #endif
902 {
903     I32 i, len, digit;
904     SV *sv;
905     AV *av;
906
907     PERL_ARGS_ASSERT_VNORMAL;
908
909     /* extract the HV from the object */
910     vs = VVERIFY(vs);
911     if ( ! vs )
912         Perl_croak(aTHX_ "Invalid version object");
913
914     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
915
916     len = av_len(av);
917     if ( len == -1 )
918     {
919         return newSVpvs("");
920     }
921     {
922         SV * tsv = *av_fetch(av, 0, 0);
923         digit = SvIV(tsv);
924     }
925     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
926     for ( i = 1 ; i <= len ; i++ ) {
927         SV * tsv = *av_fetch(av, i, 0);
928         digit = SvIV(tsv);
929         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
930     }
931
932     if ( len <= 2 ) { /* short version, must be at least three */
933         for ( len = 2 - len; len != 0; len-- )
934             sv_catpvs(sv,".0");
935     }
936     return sv;
937 }
938
939 /*
940 =for apidoc vstringify
941
942 In order to maintain maximum compatibility with earlier versions
943 of Perl, this function will return either the floating point
944 notation or the multiple dotted notation, depending on whether
945 the original version contained 1 or more dots, respectively.
946
947 The SV returned has a refcount of 1.
948
949 =cut
950 */
951
952 SV *
953 #ifdef VUTIL_REPLACE_CORE
954 Perl_vstringify2(pTHX_ SV *vs)
955 #else
956 Perl_vstringify(pTHX_ SV *vs)
957 #endif
958 {
959     SV ** svp;
960     PERL_ARGS_ASSERT_VSTRINGIFY;
961
962     /* extract the HV from the object */
963     vs = VVERIFY(vs);
964     if ( ! vs )
965         Perl_croak(aTHX_ "Invalid version object");
966
967     svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
968     if (svp) {
969         SV *pv;
970         pv = *svp;
971         if ( SvPOK(pv)
972 #if PERL_VERSION_LT(5,17,2)
973             || SvPOKp(pv)
974 #endif
975         )
976             return newSVsv(pv);
977         else
978             return &PL_sv_undef;
979     }
980     else {
981         if ( hv_existss(MUTABLE_HV(vs), "qv") )
982             return VNORMAL(vs);
983         else
984             return VNUMIFY(vs);
985     }
986 }
987
988 /*
989 =for apidoc vcmp
990
991 Version object aware cmp.  Both operands must already have been 
992 converted into version objects.
993
994 =cut
995 */
996
997 int
998 #ifdef VUTIL_REPLACE_CORE
999 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1000 #else
1001 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
1002 #endif
1003 {
1004     SSize_t i,l,m,r;
1005     I32 retval;
1006     I32 left = 0;
1007     I32 right = 0;
1008     AV *lav, *rav;
1009
1010     PERL_ARGS_ASSERT_VCMP;
1011
1012     /* extract the HVs from the objects */
1013     lhv = VVERIFY(lhv);
1014     rhv = VVERIFY(rhv);
1015     if ( ! ( lhv && rhv ) )
1016         Perl_croak(aTHX_ "Invalid version object");
1017
1018     /* get the left hand term */
1019     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
1020
1021     /* and the right hand term */
1022     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
1023
1024     l = av_len(lav);
1025     r = av_len(rav);
1026     m = l < r ? l : r;
1027     retval = 0;
1028     i = 0;
1029     while ( i <= m && retval == 0 )
1030     {
1031         SV * const lsv = *av_fetch(lav,i,0);
1032         SV * rsv;
1033         left = SvIV(lsv);
1034         rsv = *av_fetch(rav,i,0);
1035         right = SvIV(rsv);
1036         if ( left < right  )
1037             retval = -1;
1038         if ( left > right )
1039             retval = +1;
1040         i++;
1041     }
1042
1043     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1044     {
1045         if ( l < r )
1046         {
1047             while ( i <= r && retval == 0 )
1048             {
1049                 SV * const rsv = *av_fetch(rav,i,0);
1050                 if ( SvIV(rsv) != 0 )
1051                     retval = -1; /* not a match after all */
1052                 i++;
1053             }
1054         }
1055         else
1056         {
1057             while ( i <= l && retval == 0 )
1058             {
1059                 SV * const lsv = *av_fetch(lav,i,0);
1060                 if ( SvIV(lsv) != 0 )
1061                     retval = +1; /* not a match after all */
1062                 i++;
1063             }
1064         }
1065     }
1066     return retval;
1067 }
1068
1069 /* ex: set ro: */