This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
vxs.inc: Fix thinko
[perl5.git] / vutil.c
CommitLineData
abc6d738
FC
1/* This file is part of the "version" CPAN distribution. Please avoid
2 editing it in the perl core. */
3
d4e59e62
FC
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
abc6d738
FC
17#define VERSION_MAX 0x7FFFFFFF
18
19/*
20=for apidoc prescan_version
21
22Validate that a given string can be parsed as a version object, but doesn't
23actually perform the parsing. Can use either strict or lax validation rules.
24Can optionally set a number of hint variables to save the parsing code
25some time when tokenizing.
26
27=cut
28*/
29const char *
d4e59e62
FC
30#if VUTIL_REPLACE_CORE
31Perl_prescan_version2(pTHX_ const char *s, bool strict,
32#else
abc6d738 33Perl_prescan_version(pTHX_ const char *s, bool strict,
d4e59e62 34#endif
abc6d738
FC
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
58dotted_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
218version_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
241Returns a pointer to the next character after the parsed
242version string, as well as upgrading the passed in SV to
243an RV.
244
245Function must be called with an already existing SV like
246
247 sv = newSV(0);
248 s = scan_version(s, SV *sv, bool qv);
249
250Performs some preprocessing to the string to ensure that
251it has the correct characteristics of a version. Flags the
252object if it contains an underscore (which denotes this
253is an alpha version). The boolean qv denotes that the version
254should be interpreted as if it had multiple decimals, even if
255it doesn't.
256
257=cut
258*/
259
260const char *
d4e59e62
FC
261#if VUTIL_REPLACE_CORE
262Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
263#else
abc6d738 264Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
d4e59e62 265#endif
abc6d738
FC
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
d4e59e62 283 last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
abc6d738
FC
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
445Returns a new version object based on the passed in SV:
446
447 SV *sv = new_version(SV *ver);
448
449Does not alter the passed in ver SV. See "upg_version" if you
450want to upgrade the SV.
451
452=cut
453*/
454
455SV *
d4e59e62
FC
456#if VUTIL_REPLACE_CORE
457Perl_new_version2(pTHX_ SV *ver)
458#else
abc6d738 459Perl_new_version(pTHX_ SV *ver)
d4e59e62 460#endif
abc6d738
FC
461{
462 dVAR;
463 SV * const rv = newSV(0);
464 PERL_ARGS_ASSERT_NEW_VERSION;
d4e59e62 465 if ( ISA_CLASS_OBJ(ver,"version") ) /* can just copy directly */
abc6d738
FC
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 sv_setsv(rv,ver); /* make a duplicate */
525#ifdef SvVOK
526 }
527 }
528#endif
d4e59e62 529 return UPG_VERSION(rv, FALSE);
abc6d738
FC
530}
531
532/*
533=for apidoc upg_version
534
535In-place upgrade of the supplied SV to a version object.
536
537 SV *sv = upg_version(SV *sv, bool qv);
538
539Returns a pointer to the upgraded SV. Set the boolean qv if you want
540to force this SV to be interpreted as an "extended" version.
541
542=cut
543*/
544
545SV *
d4e59e62
FC
546#if VUTIL_REPLACE_CORE
547Perl_upg_version2(pTHX_ SV *ver, bool qv)
548#else
abc6d738 549Perl_upg_version(pTHX_ SV *ver, bool qv)
d4e59e62 550#endif
abc6d738
FC
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#ifdef USE_LOCALE_NUMERIC
568 char *loc = NULL;
569 if (! PL_numeric_standard) {
570 loc = savepv(setlocale(LC_NUMERIC, NULL));
571 setlocale(LC_NUMERIC, "C");
572 }
573#endif
574 if (sv) {
575 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
576 buf = SvPV(sv, len);
577 }
578 else {
579 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
580 buf = tbuf;
581 }
582#ifdef USE_LOCALE_NUMERIC
583 if (loc) {
584 setlocale(LC_NUMERIC, loc);
585 Safefree(loc);
586 }
587#endif
588 while (buf[len-1] == '0' && len > 0) len--;
589 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
590 version = savepvn(buf, len);
591 SvREFCNT_dec(sv);
592 }
593#ifdef SvVOK
594 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
595 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
596 qv = TRUE;
597 }
598#endif
599 else /* must be a string or something like a string */
600 {
601 STRLEN len;
602 version = savepv(SvPV(ver,len));
603#ifndef SvVOK
604# if PERL_VERSION > 5
605 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
606 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
607 /* may be a v-string */
608 char *testv = (char *)version;
609 STRLEN tlen = len;
610 for (tlen=0; tlen < len; tlen++, testv++) {
611 /* if one of the characters is non-text assume v-string */
612 if (testv[0] < ' ') {
613 SV * const nsv = sv_newmortal();
614 const char *nver;
615 const char *pos;
616 int saw_decimal = 0;
617 sv_setpvf(nsv,"v%vd",ver);
618 pos = nver = savepv(SvPV_nolen(nsv));
619
620 /* scan the resulting formatted string */
621 pos++; /* skip the leading 'v' */
622 while ( *pos == '.' || isDIGIT(*pos) ) {
623 if ( *pos == '.' )
624 saw_decimal++ ;
625 pos++;
626 }
627
628 /* is definitely a v-string */
629 if ( saw_decimal >= 2 ) {
630 Safefree(version);
631 version = nver;
632 }
633 break;
634 }
635 }
636 }
637# endif
638#endif
639 }
640
d4e59e62 641 s = SCAN_VERSION(version, ver, qv);
abc6d738
FC
642 if ( *s != '\0' )
643 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
644 "Version string '%s' contains invalid data; "
645 "ignoring: '%s'", version, s);
646 Safefree(version);
647 return ver;
648}
649
650/*
651=for apidoc vverify
652
653Validates that the SV contains valid internal structure for a version object.
654It may be passed either the version object (RV) or the hash itself (HV). If
655the structure is valid, it returns the HV. If the structure is invalid,
656it returns NULL.
657
658 SV *hv = vverify(sv);
659
660Note that it only confirms the bare minimum structure (so as not to get
661confused by derived classes which may contain additional hash entries):
662
663=over 4
664
665=item * The SV is an HV or a reference to an HV
666
667=item * The hash contains a "version" key
668
669=item * The "version" key has a reference to an AV as its value
670
671=back
672
673=cut
674*/
675
676SV *
d4e59e62
FC
677#if VUTIL_REPLACE_CORE
678Perl_vverify2(pTHX_ SV *vs)
679#else
abc6d738 680Perl_vverify(pTHX_ SV *vs)
d4e59e62 681#endif
abc6d738
FC
682{
683 SV *sv;
684
685 PERL_ARGS_ASSERT_VVERIFY;
686
687 if ( SvROK(vs) )
688 vs = SvRV(vs);
689
690 /* see if the appropriate elements exist */
691 if ( SvTYPE(vs) == SVt_PVHV
692 && hv_exists(MUTABLE_HV(vs), "version", 7)
693 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
694 && SvTYPE(sv) == SVt_PVAV )
695 return vs;
696 else
697 return NULL;
698}
699
700/*
701=for apidoc vnumify
702
703Accepts a version object and returns the normalized floating
704point representation. Call like:
705
706 sv = vnumify(rv);
707
708NOTE: you can pass either the object directly or the SV
709contained within the RV.
710
711The SV returned has a refcount of 1.
712
713=cut
714*/
715
716SV *
d4e59e62
FC
717#if VUTIL_REPLACE_CORE
718Perl_vnumify2(pTHX_ SV *vs)
719#else
abc6d738 720Perl_vnumify(pTHX_ SV *vs)
d4e59e62 721#endif
abc6d738
FC
722{
723 SSize_t i, len;
724 I32 digit;
725 int width;
726 bool alpha = FALSE;
727 SV *sv;
728 AV *av;
729
730 PERL_ARGS_ASSERT_VNUMIFY;
731
732 /* extract the HV from the object */
d4e59e62 733 vs = VVERIFY(vs);
abc6d738
FC
734 if ( ! vs )
735 Perl_croak(aTHX_ "Invalid version object");
736
737 /* see if various flags exist */
738 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
739 alpha = TRUE;
740 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
741 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
742 else
743 width = 3;
744
745
746 /* attempt to retrieve the version array */
747 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
748 return newSVpvs("0");
749 }
750
751 len = av_len(av);
752 if ( len == -1 )
753 {
754 return newSVpvs("0");
755 }
756
757 digit = SvIV(*av_fetch(av, 0, 0));
758 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
759 for ( i = 1 ; i < len ; i++ )
760 {
761 digit = SvIV(*av_fetch(av, i, 0));
762 if ( width < 3 ) {
763 const int denom = (width == 2 ? 10 : 100);
764 const div_t term = div((int)PERL_ABS(digit),denom);
765 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
766 }
767 else {
768 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
769 }
770 }
771
772 if ( len > 0 )
773 {
774 digit = SvIV(*av_fetch(av, len, 0));
775 if ( alpha && width == 3 ) /* alpha version */
776 sv_catpvs(sv,"_");
777 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
778 }
779 else /* len == 0 */
780 {
781 sv_catpvs(sv, "000");
782 }
783 return sv;
784}
785
786/*
787=for apidoc vnormal
788
789Accepts a version object and returns the normalized string
790representation. Call like:
791
792 sv = vnormal(rv);
793
794NOTE: you can pass either the object directly or the SV
795contained within the RV.
796
797The SV returned has a refcount of 1.
798
799=cut
800*/
801
802SV *
d4e59e62
FC
803#if VUTIL_REPLACE_CORE
804Perl_vnormal2(pTHX_ SV *vs)
805#else
abc6d738 806Perl_vnormal(pTHX_ SV *vs)
d4e59e62 807#endif
abc6d738
FC
808{
809 I32 i, len, digit;
810 bool alpha = FALSE;
811 SV *sv;
812 AV *av;
813
814 PERL_ARGS_ASSERT_VNORMAL;
815
816 /* extract the HV from the object */
d4e59e62 817 vs = VVERIFY(vs);
abc6d738
FC
818 if ( ! vs )
819 Perl_croak(aTHX_ "Invalid version object");
820
821 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
822 alpha = TRUE;
823 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
824
825 len = av_len(av);
826 if ( len == -1 )
827 {
828 return newSVpvs("");
829 }
830 digit = SvIV(*av_fetch(av, 0, 0));
831 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
832 for ( i = 1 ; i < len ; i++ ) {
833 digit = SvIV(*av_fetch(av, i, 0));
834 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
835 }
836
837 if ( len > 0 )
838 {
839 /* handle last digit specially */
840 digit = SvIV(*av_fetch(av, len, 0));
841 if ( alpha )
842 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
843 else
844 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
845 }
846
847 if ( len <= 2 ) { /* short version, must be at least three */
848 for ( len = 2 - len; len != 0; len-- )
849 sv_catpvs(sv,".0");
850 }
851 return sv;
852}
853
854/*
855=for apidoc vstringify
856
857In order to maintain maximum compatibility with earlier versions
858of Perl, this function will return either the floating point
859notation or the multiple dotted notation, depending on whether
860the original version contained 1 or more dots, respectively.
861
862The SV returned has a refcount of 1.
863
864=cut
865*/
866
867SV *
d4e59e62
FC
868#if VUTIL_REPLACE_CORE
869Perl_vstringify2(pTHX_ SV *vs)
870#else
abc6d738 871Perl_vstringify(pTHX_ SV *vs)
d4e59e62 872#endif
abc6d738
FC
873{
874 PERL_ARGS_ASSERT_VSTRINGIFY;
875
876 /* extract the HV from the object */
d4e59e62 877 vs = VVERIFY(vs);
abc6d738
FC
878 if ( ! vs )
879 Perl_croak(aTHX_ "Invalid version object");
880
881 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
882 SV *pv;
883 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
884 if ( SvPOK(pv) )
885 return newSVsv(pv);
886 else
887 return &PL_sv_undef;
888 }
889 else {
890 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
d4e59e62 891 return VNORMAL(vs);
abc6d738 892 else
d4e59e62 893 return VNUMIFY(vs);
abc6d738
FC
894 }
895}
896
897/*
898=for apidoc vcmp
899
900Version object aware cmp. Both operands must already have been
901converted into version objects.
902
903=cut
904*/
905
906int
d4e59e62
FC
907#if VUTIL_REPLACE_CORE
908Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
909#else
abc6d738 910Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
d4e59e62 911#endif
abc6d738
FC
912{
913 SSize_t i,l,m,r;
914 I32 retval;
915 bool lalpha = FALSE;
916 bool ralpha = FALSE;
917 I32 left = 0;
918 I32 right = 0;
919 AV *lav, *rav;
920
921 PERL_ARGS_ASSERT_VCMP;
922
923 /* extract the HVs from the objects */
d4e59e62
FC
924 lhv = VVERIFY(lhv);
925 rhv = VVERIFY(rhv);
abc6d738
FC
926 if ( ! ( lhv && rhv ) )
927 Perl_croak(aTHX_ "Invalid version object");
928
929 /* get the left hand term */
930 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
931 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
932 lalpha = TRUE;
933
934 /* and the right hand term */
935 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
936 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
937 ralpha = TRUE;
938
939 l = av_len(lav);
940 r = av_len(rav);
941 m = l < r ? l : r;
942 retval = 0;
943 i = 0;
944 while ( i <= m && retval == 0 )
945 {
946 left = SvIV(*av_fetch(lav,i,0));
947 right = SvIV(*av_fetch(rav,i,0));
948 if ( left < right )
949 retval = -1;
950 if ( left > right )
951 retval = +1;
952 i++;
953 }
954
955 /* tiebreaker for alpha with identical terms */
956 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
957 {
958 if ( lalpha && !ralpha )
959 {
960 retval = -1;
961 }
962 else if ( ralpha && !lalpha)
963 {
964 retval = +1;
965 }
966 }
967
968 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
969 {
970 if ( l < r )
971 {
972 while ( i <= r && retval == 0 )
973 {
974 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
975 retval = -1; /* not a match after all */
976 i++;
977 }
978 }
979 else
980 {
981 while ( i <= l && retval == 0 )
982 {
983 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
984 retval = +1; /* not a match after all */
985 i++;
986 }
987 }
988 }
989 return retval;
990}