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