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