This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Lots of C optimizations for both speed/correctness
[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 #  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 =for apidoc prescan_version
22
23 Validate that a given string can be parsed as a version object, but doesn't
24 actually perform the parsing.  Can use either strict or lax validation rules.
25 Can optionally set a number of hint variables to save the parsing code
26 some time when tokenizing.
27
28 =cut
29 */
30 const char *
31 #if VUTIL_REPLACE_CORE
32 Perl_prescan_version2(pTHX_ const char *s, bool strict,
33 #else
34 Perl_prescan_version(pTHX_ const char *s, bool strict,
35 #endif
36                      const char **errstr,
37                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
38     bool qv = (sqv ? *sqv : FALSE);
39     int width = 3;
40     int saw_decimal = 0;
41     bool alpha = FALSE;
42     const char *d = s;
43
44     PERL_ARGS_ASSERT_PRESCAN_VERSION;
45
46     if (qv && isDIGIT(*d))
47         goto dotted_decimal_version;
48
49     if (*d == 'v') { /* explicit v-string */
50         d++;
51         if (isDIGIT(*d)) {
52             qv = TRUE;
53         }
54         else { /* degenerate v-string */
55             /* requires v1.2.3 */
56             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
57         }
58
59 dotted_decimal_version:
60         if (strict && d[0] == '0' && isDIGIT(d[1])) {
61             /* no leading zeros allowed */
62             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
63         }
64
65         while (isDIGIT(*d))     /* integer part */
66             d++;
67
68         if (*d == '.')
69         {
70             saw_decimal++;
71             d++;                /* decimal point */
72         }
73         else
74         {
75             if (strict) {
76                 /* require v1.2.3 */
77                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
78             }
79             else {
80                 goto version_prescan_finish;
81             }
82         }
83
84         {
85             int i = 0;
86             int j = 0;
87             while (isDIGIT(*d)) {       /* just keep reading */
88                 i++;
89                 while (isDIGIT(*d)) {
90                     d++; j++;
91                     /* maximum 3 digits between decimal */
92                     if (strict && j > 3) {
93                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
94                     }
95                 }
96                 if (*d == '_') {
97                     if (strict) {
98                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
99                     }
100                     if ( alpha ) {
101                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
102                     }
103                     d++;
104                     alpha = TRUE;
105                 }
106                 else if (*d == '.') {
107                     if (alpha) {
108                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
109                     }
110                     saw_decimal++;
111                     d++;
112                 }
113                 else if (!isDIGIT(*d)) {
114                     break;
115                 }
116                 j = 0;
117             }
118
119             if (strict && i < 2) {
120                 /* requires v1.2.3 */
121                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
122             }
123         }
124     }                                   /* end if dotted-decimal */
125     else
126     {                                   /* decimal versions */
127         int j = 0;                      /* may need this later */
128         /* special strict case for leading '.' or '0' */
129         if (strict) {
130             if (*d == '.') {
131                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
132             }
133             if (*d == '0' && isDIGIT(d[1])) {
134                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
135             }
136         }
137
138         /* and we never support negative versions */
139         if ( *d == '-') {
140             BADVERSION(s,errstr,"Invalid version format (negative version number)");
141         }
142
143         /* consume all of the integer part */
144         while (isDIGIT(*d))
145             d++;
146
147         /* look for a fractional part */
148         if (*d == '.') {
149             /* we found it, so consume it */
150             saw_decimal++;
151             d++;
152         }
153         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
154             if ( d == s ) {
155                 /* found nothing */
156                 BADVERSION(s,errstr,"Invalid version format (version required)");
157             }
158             /* found just an integer */
159             goto version_prescan_finish;
160         }
161         else if ( d == s ) {
162             /* didn't find either integer or period */
163             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
164         }
165         else if (*d == '_') {
166             /* underscore can't come after integer part */
167             if (strict) {
168                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
169             }
170             else if (isDIGIT(d[1])) {
171                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
172             }
173             else {
174                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
175             }
176         }
177         else {
178             /* anything else after integer part is just invalid data */
179             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
180         }
181
182         /* scan the fractional part after the decimal point*/
183
184         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
185                 /* strict or lax-but-not-the-end */
186                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
187         }
188
189         while (isDIGIT(*d)) {
190             d++; j++;
191             if (*d == '.' && isDIGIT(d[-1])) {
192                 if (alpha) {
193                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
194                 }
195                 if (strict) {
196                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
197                 }
198                 d = (char *)s;          /* start all over again */
199                 qv = TRUE;
200                 goto dotted_decimal_version;
201             }
202             if (*d == '_') {
203                 if (strict) {
204                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
205                 }
206                 if ( alpha ) {
207                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
208                 }
209                 if ( ! isDIGIT(d[1]) ) {
210                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
211                 }
212                 width = j;
213                 d++;
214                 alpha = TRUE;
215             }
216         }
217     }
218
219 version_prescan_finish:
220     while (isSPACE(*d))
221         d++;
222
223     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
224         /* trailing non-numeric data */
225         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
226     }
227
228     if (sqv)
229         *sqv = qv;
230     if (swidth)
231         *swidth = width;
232     if (ssaw_decimal)
233         *ssaw_decimal = saw_decimal;
234     if (salpha)
235         *salpha = alpha;
236     return d;
237 }
238
239 /*
240 =for apidoc scan_version
241
242 Returns a pointer to the next character after the parsed
243 version string, as well as upgrading the passed in SV to
244 an RV.
245
246 Function must be called with an already existing SV like
247
248     sv = newSV(0);
249     s = scan_version(s, SV *sv, bool qv);
250
251 Performs some preprocessing to the string to ensure that
252 it has the correct characteristics of a version.  Flags the
253 object if it contains an underscore (which denotes this
254 is an alpha version).  The boolean qv denotes that the version
255 should be interpreted as if it had multiple decimals, even if
256 it doesn't.
257
258 =cut
259 */
260
261 const char *
262 #if VUTIL_REPLACE_CORE
263 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
264 #else
265 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
266 #endif
267 {
268     const char *start = s;
269     const char *pos;
270     const char *last;
271     const char *errstr = NULL;
272     int saw_decimal = 0;
273     int width = 3;
274     bool alpha = FALSE;
275     bool vinf = FALSE;
276     AV * av;
277     SV * hv;
278
279     PERL_ARGS_ASSERT_SCAN_VERSION;
280
281     while (isSPACE(*s)) /* leading whitespace is OK */
282         s++;
283
284     last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
285     if (errstr) {
286         /* "undef" is a special case and not an error */
287         if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
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 = AvFILLp(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+1,"ndef") ) {
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_VERSION_OBJ(ver) ) /* 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             SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
488             if(svp) {
489                 const I32 width = SvIV(*svp);
490                 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
491             }
492         }
493         {
494             SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
495             if(svp)
496                 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
497         }
498         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
499         /* This will get reblessed later if a derived class*/
500         for ( key = 0; key <= av_len(sav); key++ )
501         {
502             SV * const sv = *av_fetch(sav, key, FALSE);
503             const I32 rev = SvIV(sv);
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             const char * const version = (const char*)mg->mg_ptr;
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         }
521         else {
522 #endif
523         SvSetSV_nosteal(rv, ver); /* make a duplicate */
524 #ifdef SvVOK
525         }
526     }
527 #endif
528     return UPG_VERSION(rv, FALSE);
529 }
530
531 /*
532 =for apidoc upg_version
533
534 In-place upgrade of the supplied SV to a version object.
535
536     SV *sv = upg_version(SV *sv, bool qv);
537
538 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
539 to force this SV to be interpreted as an "extended" version.
540
541 =cut
542 */
543
544 SV *
545 #if VUTIL_REPLACE_CORE
546 Perl_upg_version2(pTHX_ SV *ver, bool qv)
547 #else
548 Perl_upg_version(pTHX_ SV *ver, bool qv)
549 #endif
550 {
551     const char *version, *s;
552 #ifdef SvVOK
553     const MAGIC *mg;
554 #endif
555
556     PERL_ARGS_ASSERT_UPG_VERSION;
557
558     if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
559     {
560         STRLEN len;
561
562         /* may get too much accuracy */ 
563         char tbuf[64];
564         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
565         char *buf;
566         STORE_NUMERIC_LOCAL_SET_STANDARD();
567         if (sv) {
568             Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
569             len = SvCUR(sv);
570             buf = SvPVX(sv);
571         }
572         else {
573             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
574             buf = tbuf;
575         }
576         RESTORE_NUMERIC_LOCAL();
577         while (buf[len-1] == '0' && len > 0) len--;
578         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
579         version = savepvn(buf, len);
580         SAVEFREEPV(version);
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         SAVEFREEPV(version);
587         qv = TRUE;
588     }
589 #endif
590     else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
591            || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
592         /* out of bounds [unsigned] integer */
593         STRLEN len;
594         char tbuf[64];
595         len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
596         version = savepvn(tbuf, len);
597         SAVEFREEPV(version);
598         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
599                        "Integer overflow in version %d",VERSION_MAX);
600     }
601     else if ( SvUOK(ver) || SvIOK(ver) ) {
602         version = savesvpv(ver);
603         SAVEFREEPV(version);
604     }
605     else if ( SvPOK(ver) )/* must be a string or something like a string */
606     {
607         STRLEN len;
608         version = savepvn(SvPV(ver,len), SvCUR(ver));
609         SAVEFREEPV(version);
610 #ifndef SvVOK
611 #  if PERL_VERSION > 5
612         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
613         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
614             /* may be a v-string */
615             char *testv = (char *)version;
616             STRLEN tlen = len;
617             for (tlen=0; tlen < len; tlen++, testv++) {
618                 /* if one of the characters is non-text assume v-string */
619                 if (testv[0] < ' ') {
620                     SV * const nsv = sv_newmortal();
621                     const char *nver;
622                     const char *pos;
623                     int saw_decimal = 0;
624                     sv_setpvf(nsv,"v%vd",ver);
625                     pos = nver = savepv(SvPV_nolen(nsv));
626                     SAVEFREEPV(pos);
627
628                     /* scan the resulting formatted string */
629                     pos++; /* skip the leading 'v' */
630                     while ( *pos == '.' || isDIGIT(*pos) ) {
631                         if ( *pos == '.' )
632                             saw_decimal++ ;
633                         pos++;
634                     }
635
636                     /* is definitely a v-string */
637                     if ( saw_decimal >= 2 ) {
638                         version = nver;
639                     }
640                     break;
641                 }
642             }
643         }
644 #  endif
645 #endif
646     }
647     else
648     {
649         /* no idea what this is */
650         Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
651     }
652
653     s = SCAN_VERSION(version, ver, qv);
654     if ( *s != '\0' ) 
655         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
656                        "Version string '%s' contains invalid data; "
657                        "ignoring: '%s'", version, s);
658     return ver;
659 }
660
661 /*
662 =for apidoc vverify
663
664 Validates that the SV contains valid internal structure for a version object.
665 It may be passed either the version object (RV) or the hash itself (HV).  If
666 the structure is valid, it returns the HV.  If the structure is invalid,
667 it returns NULL.
668
669     SV *hv = vverify(sv);
670
671 Note that it only confirms the bare minimum structure (so as not to get
672 confused by derived classes which may contain additional hash entries):
673
674 =over 4
675
676 =item * The SV is an HV or a reference to an HV
677
678 =item * The hash contains a "version" key
679
680 =item * The "version" key has a reference to an AV as its value
681
682 =back
683
684 =cut
685 */
686
687 SV *
688 #if VUTIL_REPLACE_CORE
689 Perl_vverify2(pTHX_ SV *vs)
690 #else
691 Perl_vverify(pTHX_ SV *vs)
692 #endif
693 {
694     SV *sv;
695     SV **svp;
696
697     PERL_ARGS_ASSERT_VVERIFY;
698
699     if ( SvROK(vs) )
700         vs = SvRV(vs);
701
702     /* see if the appropriate elements exist */
703     if ( SvTYPE(vs) == SVt_PVHV
704          && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
705          && (sv = SvRV(*svp))
706          && SvTYPE(sv) == SVt_PVAV )
707         return vs;
708     else
709         return NULL;
710 }
711
712 /*
713 =for apidoc vnumify
714
715 Accepts a version object and returns the normalized floating
716 point representation.  Call like:
717
718     sv = vnumify(rv);
719
720 NOTE: you can pass either the object directly or the SV
721 contained within the RV.
722
723 The SV returned has a refcount of 1.
724
725 =cut
726 */
727
728 SV *
729 #if VUTIL_REPLACE_CORE
730 Perl_vnumify2(pTHX_ SV *vs)
731 #else
732 Perl_vnumify(pTHX_ SV *vs)
733 #endif
734 {
735     SSize_t i, len;
736     I32 digit;
737     int width;
738     bool alpha = FALSE;
739     SV *sv;
740     AV *av;
741
742     PERL_ARGS_ASSERT_VNUMIFY;
743
744     /* extract the HV from the object */
745     vs = VVERIFY(vs);
746     if ( ! vs )
747         Perl_croak(aTHX_ "Invalid version object");
748
749     /* see if various flags exist */
750     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
751         alpha = TRUE;
752     {
753         SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
754         if ( svp )
755             width = SvIV(*svp);
756         else
757             width = 3;
758     }
759
760
761     /* attempt to retrieve the version array */
762     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
763         return newSVpvs("0");
764     }
765
766     len = av_len(av);
767     if ( len == -1 )
768     {
769         return newSVpvs("0");
770     }
771
772     {
773         SV * tsv = *av_fetch(av, 0, 0);
774         digit = SvIV(tsv);
775     }
776     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
777     for ( i = 1 ; i < len ; i++ )
778     {
779         SV * tsv = *av_fetch(av, i, 0);
780         digit = SvIV(tsv);
781         if ( width < 3 ) {
782             const int denom = (width == 2 ? 10 : 100);
783             const div_t term = div((int)PERL_ABS(digit),denom);
784             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
785         }
786         else {
787             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
788         }
789     }
790
791     if ( len > 0 )
792     {
793         SV * tsv = *av_fetch(av, len, 0);
794         digit = SvIV(tsv);
795         if ( alpha && width == 3 ) /* alpha version */
796             sv_catpvs(sv,"_");
797         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
798     }
799     else /* len == 0 */
800     {
801         sv_catpvs(sv, "000");
802     }
803     return sv;
804 }
805
806 /*
807 =for apidoc vnormal
808
809 Accepts a version object and returns the normalized string
810 representation.  Call like:
811
812     sv = vnormal(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 #if VUTIL_REPLACE_CORE
824 Perl_vnormal2(pTHX_ SV *vs)
825 #else
826 Perl_vnormal(pTHX_ SV *vs)
827 #endif
828 {
829     I32 i, len, digit;
830     bool alpha = FALSE;
831     SV *sv;
832     AV *av;
833
834     PERL_ARGS_ASSERT_VNORMAL;
835
836     /* extract the HV from the object */
837     vs = VVERIFY(vs);
838     if ( ! vs )
839         Perl_croak(aTHX_ "Invalid version object");
840
841     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
842         alpha = TRUE;
843     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
844
845     len = av_len(av);
846     if ( len == -1 )
847     {
848         return newSVpvs("");
849     }
850     {
851         SV * tsv = *av_fetch(av, 0, 0);
852         digit = SvIV(tsv);
853     }
854     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
855     for ( i = 1 ; i < len ; i++ ) {
856         SV * tsv = *av_fetch(av, i, 0);
857         digit = SvIV(tsv);
858         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
859     }
860
861     if ( len > 0 )
862     {
863         /* handle last digit specially */
864         SV * tsv = *av_fetch(av, len, 0);
865         digit = SvIV(tsv);
866         if ( alpha )
867             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
868         else
869             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
870     }
871
872     if ( len <= 2 ) { /* short version, must be at least three */
873         for ( len = 2 - len; len != 0; len-- )
874             sv_catpvs(sv,".0");
875     }
876     return sv;
877 }
878
879 /*
880 =for apidoc vstringify
881
882 In order to maintain maximum compatibility with earlier versions
883 of Perl, this function will return either the floating point
884 notation or the multiple dotted notation, depending on whether
885 the original version contained 1 or more dots, respectively.
886
887 The SV returned has a refcount of 1.
888
889 =cut
890 */
891
892 SV *
893 #if VUTIL_REPLACE_CORE
894 Perl_vstringify2(pTHX_ SV *vs)
895 #else
896 Perl_vstringify(pTHX_ SV *vs)
897 #endif
898 {
899     SV ** svp;
900     PERL_ARGS_ASSERT_VSTRINGIFY;
901
902     /* extract the HV from the object */
903     vs = VVERIFY(vs);
904     if ( ! vs )
905         Perl_croak(aTHX_ "Invalid version object");
906
907     svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
908     if (svp) {
909         SV *pv;
910         pv = *svp;
911         if ( SvPOK(pv) )
912             return newSVsv(pv);
913         else
914             return &PL_sv_undef;
915     }
916     else {
917         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
918             return VNORMAL(vs);
919         else
920             return VNUMIFY(vs);
921     }
922 }
923
924 /*
925 =for apidoc vcmp
926
927 Version object aware cmp.  Both operands must already have been 
928 converted into version objects.
929
930 =cut
931 */
932
933 int
934 #if VUTIL_REPLACE_CORE
935 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
936 #else
937 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
938 #endif
939 {
940     SSize_t i,l,m,r;
941     I32 retval;
942     bool lalpha = FALSE;
943     bool ralpha = FALSE;
944     I32 left = 0;
945     I32 right = 0;
946     AV *lav, *rav;
947
948     PERL_ARGS_ASSERT_VCMP;
949
950     /* extract the HVs from the objects */
951     lhv = VVERIFY(lhv);
952     rhv = VVERIFY(rhv);
953     if ( ! ( lhv && rhv ) )
954         Perl_croak(aTHX_ "Invalid version object");
955
956     /* get the left hand term */
957     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
958     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
959         lalpha = TRUE;
960
961     /* and the right hand term */
962     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
963     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
964         ralpha = TRUE;
965
966     l = av_len(lav);
967     r = av_len(rav);
968     m = l < r ? l : r;
969     retval = 0;
970     i = 0;
971     while ( i <= m && retval == 0 )
972     {
973         SV * const lsv = *av_fetch(lav,i,0);
974         SV * rsv;
975         left = SvIV(lsv);
976         rsv = *av_fetch(rav,i,0);
977         right = SvIV(rsv);
978         if ( left < right  )
979             retval = -1;
980         if ( left > right )
981             retval = +1;
982         i++;
983     }
984
985     /* tiebreaker for alpha with identical terms */
986     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
987     {
988         if ( lalpha && !ralpha )
989         {
990             retval = -1;
991         }
992         else if ( ralpha && !lalpha)
993         {
994             retval = +1;
995         }
996     }
997
998     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
999     {
1000         if ( l < r )
1001         {
1002             while ( i <= r && retval == 0 )
1003             {
1004                 SV * const rsv = *av_fetch(rav,i,0);
1005                 if ( SvIV(rsv) != 0 )
1006                     retval = -1; /* not a match after all */
1007                 i++;
1008             }
1009         }
1010         else
1011         {
1012             while ( i <= l && retval == 0 )
1013             {
1014                 SV * const lsv = *av_fetch(lav,i,0);
1015                 if ( SvIV(lsv) != 0 )
1016                     retval = +1; /* not a match after all */
1017                 i++;
1018             }
1019         }
1020     }
1021     return retval;
1022 }