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