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