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