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