This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Import vutil.h from the CPAN version dist
[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
4#define VERSION_MAX 0x7FFFFFFF
5
6/*
7=for apidoc prescan_version
8
9Validate that a given string can be parsed as a version object, but doesn't
10actually perform the parsing. Can use either strict or lax validation rules.
11Can optionally set a number of hint variables to save the parsing code
12some time when tokenizing.
13
14=cut
15*/
16const char *
17Perl_prescan_version(pTHX_ const char *s, bool strict,
18 const char **errstr,
19 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
20 bool qv = (sqv ? *sqv : FALSE);
21 int width = 3;
22 int saw_decimal = 0;
23 bool alpha = FALSE;
24 const char *d = s;
25
26 PERL_ARGS_ASSERT_PRESCAN_VERSION;
27
28 if (qv && isDIGIT(*d))
29 goto dotted_decimal_version;
30
31 if (*d == 'v') { /* explicit v-string */
32 d++;
33 if (isDIGIT(*d)) {
34 qv = TRUE;
35 }
36 else { /* degenerate v-string */
37 /* requires v1.2.3 */
38 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
39 }
40
41dotted_decimal_version:
42 if (strict && d[0] == '0' && isDIGIT(d[1])) {
43 /* no leading zeros allowed */
44 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
45 }
46
47 while (isDIGIT(*d)) /* integer part */
48 d++;
49
50 if (*d == '.')
51 {
52 saw_decimal++;
53 d++; /* decimal point */
54 }
55 else
56 {
57 if (strict) {
58 /* require v1.2.3 */
59 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
60 }
61 else {
62 goto version_prescan_finish;
63 }
64 }
65
66 {
67 int i = 0;
68 int j = 0;
69 while (isDIGIT(*d)) { /* just keep reading */
70 i++;
71 while (isDIGIT(*d)) {
72 d++; j++;
73 /* maximum 3 digits between decimal */
74 if (strict && j > 3) {
75 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
76 }
77 }
78 if (*d == '_') {
79 if (strict) {
80 BADVERSION(s,errstr,"Invalid version format (no underscores)");
81 }
82 if ( alpha ) {
83 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
84 }
85 d++;
86 alpha = TRUE;
87 }
88 else if (*d == '.') {
89 if (alpha) {
90 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
91 }
92 saw_decimal++;
93 d++;
94 }
95 else if (!isDIGIT(*d)) {
96 break;
97 }
98 j = 0;
99 }
100
101 if (strict && i < 2) {
102 /* requires v1.2.3 */
103 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
104 }
105 }
106 } /* end if dotted-decimal */
107 else
108 { /* decimal versions */
109 int j = 0; /* may need this later */
110 /* special strict case for leading '.' or '0' */
111 if (strict) {
112 if (*d == '.') {
113 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
114 }
115 if (*d == '0' && isDIGIT(d[1])) {
116 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
117 }
118 }
119
120 /* and we never support negative versions */
121 if ( *d == '-') {
122 BADVERSION(s,errstr,"Invalid version format (negative version number)");
123 }
124
125 /* consume all of the integer part */
126 while (isDIGIT(*d))
127 d++;
128
129 /* look for a fractional part */
130 if (*d == '.') {
131 /* we found it, so consume it */
132 saw_decimal++;
133 d++;
134 }
135 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
136 if ( d == s ) {
137 /* found nothing */
138 BADVERSION(s,errstr,"Invalid version format (version required)");
139 }
140 /* found just an integer */
141 goto version_prescan_finish;
142 }
143 else if ( d == s ) {
144 /* didn't find either integer or period */
145 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
146 }
147 else if (*d == '_') {
148 /* underscore can't come after integer part */
149 if (strict) {
150 BADVERSION(s,errstr,"Invalid version format (no underscores)");
151 }
152 else if (isDIGIT(d[1])) {
153 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
154 }
155 else {
156 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
157 }
158 }
159 else {
160 /* anything else after integer part is just invalid data */
161 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
162 }
163
164 /* scan the fractional part after the decimal point*/
165
166 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
167 /* strict or lax-but-not-the-end */
168 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
169 }
170
171 while (isDIGIT(*d)) {
172 d++; j++;
173 if (*d == '.' && isDIGIT(d[-1])) {
174 if (alpha) {
175 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
176 }
177 if (strict) {
178 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
179 }
180 d = (char *)s; /* start all over again */
181 qv = TRUE;
182 goto dotted_decimal_version;
183 }
184 if (*d == '_') {
185 if (strict) {
186 BADVERSION(s,errstr,"Invalid version format (no underscores)");
187 }
188 if ( alpha ) {
189 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
190 }
191 if ( ! isDIGIT(d[1]) ) {
192 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
193 }
194 width = j;
195 d++;
196 alpha = TRUE;
197 }
198 }
199 }
200
201version_prescan_finish:
202 while (isSPACE(*d))
203 d++;
204
205 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
206 /* trailing non-numeric data */
207 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
208 }
209
210 if (sqv)
211 *sqv = qv;
212 if (swidth)
213 *swidth = width;
214 if (ssaw_decimal)
215 *ssaw_decimal = saw_decimal;
216 if (salpha)
217 *salpha = alpha;
218 return d;
219}
220
221/*
222=for apidoc scan_version
223
224Returns a pointer to the next character after the parsed
225version string, as well as upgrading the passed in SV to
226an RV.
227
228Function must be called with an already existing SV like
229
230 sv = newSV(0);
231 s = scan_version(s, SV *sv, bool qv);
232
233Performs some preprocessing to the string to ensure that
234it has the correct characteristics of a version. Flags the
235object if it contains an underscore (which denotes this
236is an alpha version). The boolean qv denotes that the version
237should be interpreted as if it had multiple decimals, even if
238it doesn't.
239
240=cut
241*/
242
243const char *
244Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
245{
246 const char *start = s;
247 const char *pos;
248 const char *last;
249 const char *errstr = NULL;
250 int saw_decimal = 0;
251 int width = 3;
252 bool alpha = FALSE;
253 bool vinf = FALSE;
254 AV * av;
255 SV * hv;
256
257 PERL_ARGS_ASSERT_SCAN_VERSION;
258
259 while (isSPACE(*s)) /* leading whitespace is OK */
260 s++;
261
262 last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
263 if (errstr) {
264 /* "undef" is a special case and not an error */
265 if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
266 Safefree(start);
267 Perl_croak(aTHX_ "%s", errstr);
268 }
269 }
270
271 start = s;
272 if (*s == 'v')
273 s++;
274 pos = s;
275
276 /* Now that we are through the prescan, start creating the object */
277 av = newAV();
278 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
279 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
280
281#ifndef NODEFAULT_SHAREKEYS
282 HvSHAREKEYS_on(hv); /* key-sharing on by default */
283#endif
284
285 if ( qv )
286 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
287 if ( alpha )
288 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
289 if ( !qv && width < 3 )
290 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
291
292 while (isDIGIT(*pos))
293 pos++;
294 if (!isALPHA(*pos)) {
295 I32 rev;
296
297 for (;;) {
298 rev = 0;
299 {
300 /* this is atoi() that delimits on underscores */
301 const char *end = pos;
302 I32 mult = 1;
303 I32 orev;
304
305 /* the following if() will only be true after the decimal
306 * point of a version originally created with a bare
307 * floating point number, i.e. not quoted in any way
308 */
309 if ( !qv && s > start && saw_decimal == 1 ) {
310 mult *= 100;
311 while ( s < end ) {
312 orev = rev;
313 rev += (*s - '0') * mult;
314 mult /= 10;
315 if ( (PERL_ABS(orev) > PERL_ABS(rev))
316 || (PERL_ABS(rev) > VERSION_MAX )) {
317 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
318 "Integer overflow in version %d",VERSION_MAX);
319 s = end - 1;
320 rev = VERSION_MAX;
321 vinf = 1;
322 }
323 s++;
324 if ( *s == '_' )
325 s++;
326 }
327 }
328 else {
329 while (--end >= s) {
330 orev = rev;
331 rev += (*end - '0') * mult;
332 mult *= 10;
333 if ( (PERL_ABS(orev) > PERL_ABS(rev))
334 || (PERL_ABS(rev) > VERSION_MAX )) {
335 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
336 "Integer overflow in version");
337 end = s - 1;
338 rev = VERSION_MAX;
339 vinf = 1;
340 }
341 }
342 }
343 }
344
345 /* Append revision */
346 av_push(av, newSViv(rev));
347 if ( vinf ) {
348 s = last;
349 break;
350 }
351 else if ( *pos == '.' )
352 s = ++pos;
353 else if ( *pos == '_' && isDIGIT(pos[1]) )
354 s = ++pos;
355 else if ( *pos == ',' && isDIGIT(pos[1]) )
356 s = ++pos;
357 else if ( isDIGIT(*pos) )
358 s = pos;
359 else {
360 s = pos;
361 break;
362 }
363 if ( qv ) {
364 while ( isDIGIT(*pos) )
365 pos++;
366 }
367 else {
368 int digits = 0;
369 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
370 if ( *pos != '_' )
371 digits++;
372 pos++;
373 }
374 }
375 }
376 }
377 if ( qv ) { /* quoted versions always get at least three terms*/
378 SSize_t len = av_len(av);
379 /* This for loop appears to trigger a compiler bug on OS X, as it
380 loops infinitely. Yes, len is negative. No, it makes no sense.
381 Compiler in question is:
382 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
383 for ( len = 2 - len; len > 0; len-- )
384 av_push(MUTABLE_AV(sv), newSViv(0));
385 */
386 len = 2 - len;
387 while (len-- > 0)
388 av_push(av, newSViv(0));
389 }
390
391 /* need to save off the current version string for later */
392 if ( vinf ) {
393 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
394 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
395 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
396 }
397 else if ( s > start ) {
398 SV * orig = newSVpvn(start,s-start);
399 if ( qv && saw_decimal == 1 && *start != 'v' ) {
400 /* need to insert a v to be consistent */
401 sv_insert(orig, 0, 0, "v", 1);
402 }
403 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
404 }
405 else {
406 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
407 av_push(av, newSViv(0));
408 }
409
410 /* And finally, store the AV in the hash */
411 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
412
413 /* fix RT#19517 - special case 'undef' as string */
414 if ( *s == 'u' && strEQ(s,"undef") ) {
415 s += 5;
416 }
417
418 return s;
419}
420
421/*
422=for apidoc new_version
423
424Returns a new version object based on the passed in SV:
425
426 SV *sv = new_version(SV *ver);
427
428Does not alter the passed in ver SV. See "upg_version" if you
429want to upgrade the SV.
430
431=cut
432*/
433
434SV *
435Perl_new_version(pTHX_ SV *ver)
436{
437 dVAR;
438 SV * const rv = newSV(0);
439 PERL_ARGS_ASSERT_NEW_VERSION;
440 if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
441 /* can just copy directly */
442 {
443 SSize_t key;
444 AV * const av = newAV();
445 AV *sav;
446 /* This will get reblessed later if a derived class*/
447 SV * const hv = newSVrv(rv, "version");
448 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
449#ifndef NODEFAULT_SHAREKEYS
450 HvSHAREKEYS_on(hv); /* key-sharing on by default */
451#endif
452
453 if ( SvROK(ver) )
454 ver = SvRV(ver);
455
456 /* Begin copying all of the elements */
457 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
458 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
459
460 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
461 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
462
463 if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
464 {
465 const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
466 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
467 }
468
469 if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
470 {
471 SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
472 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
473 }
474
475 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
476 /* This will get reblessed later if a derived class*/
477 for ( key = 0; key <= av_len(sav); key++ )
478 {
479 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
480 av_push(av, newSViv(rev));
481 }
482
483 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
484 return rv;
485 }
486#ifdef SvVOK
487 {
488 const MAGIC* const mg = SvVSTRING_mg(ver);
489 if ( mg ) { /* already a v-string */
490 const STRLEN len = mg->mg_len;
491 char * const version = savepvn( (const char*)mg->mg_ptr, len);
492 sv_setpvn(rv,version,len);
493 /* this is for consistency with the pure Perl class */
494 if ( isDIGIT(*version) )
495 sv_insert(rv, 0, 0, "v", 1);
496 Safefree(version);
497 }
498 else {
499#endif
500 sv_setsv(rv,ver); /* make a duplicate */
501#ifdef SvVOK
502 }
503 }
504#endif
505 return upg_version(rv, FALSE);
506}
507
508/*
509=for apidoc upg_version
510
511In-place upgrade of the supplied SV to a version object.
512
513 SV *sv = upg_version(SV *sv, bool qv);
514
515Returns a pointer to the upgraded SV. Set the boolean qv if you want
516to force this SV to be interpreted as an "extended" version.
517
518=cut
519*/
520
521SV *
522Perl_upg_version(pTHX_ SV *ver, bool qv)
523{
524 const char *version, *s;
525#ifdef SvVOK
526 const MAGIC *mg;
527#endif
528
529 PERL_ARGS_ASSERT_UPG_VERSION;
530
531 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
532 {
533 STRLEN len;
534
535 /* may get too much accuracy */
536 char tbuf[64];
537 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
538 char *buf;
539#ifdef USE_LOCALE_NUMERIC
540 char *loc = NULL;
541 if (! PL_numeric_standard) {
542 loc = savepv(setlocale(LC_NUMERIC, NULL));
543 setlocale(LC_NUMERIC, "C");
544 }
545#endif
546 if (sv) {
547 Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
548 buf = SvPV(sv, len);
549 }
550 else {
551 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
552 buf = tbuf;
553 }
554#ifdef USE_LOCALE_NUMERIC
555 if (loc) {
556 setlocale(LC_NUMERIC, loc);
557 Safefree(loc);
558 }
559#endif
560 while (buf[len-1] == '0' && len > 0) len--;
561 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
562 version = savepvn(buf, len);
563 SvREFCNT_dec(sv);
564 }
565#ifdef SvVOK
566 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
567 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
568 qv = TRUE;
569 }
570#endif
571 else /* must be a string or something like a string */
572 {
573 STRLEN len;
574 version = savepv(SvPV(ver,len));
575#ifndef SvVOK
576# if PERL_VERSION > 5
577 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
578 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
579 /* may be a v-string */
580 char *testv = (char *)version;
581 STRLEN tlen = len;
582 for (tlen=0; tlen < len; tlen++, testv++) {
583 /* if one of the characters is non-text assume v-string */
584 if (testv[0] < ' ') {
585 SV * const nsv = sv_newmortal();
586 const char *nver;
587 const char *pos;
588 int saw_decimal = 0;
589 sv_setpvf(nsv,"v%vd",ver);
590 pos = nver = savepv(SvPV_nolen(nsv));
591
592 /* scan the resulting formatted string */
593 pos++; /* skip the leading 'v' */
594 while ( *pos == '.' || isDIGIT(*pos) ) {
595 if ( *pos == '.' )
596 saw_decimal++ ;
597 pos++;
598 }
599
600 /* is definitely a v-string */
601 if ( saw_decimal >= 2 ) {
602 Safefree(version);
603 version = nver;
604 }
605 break;
606 }
607 }
608 }
609# endif
610#endif
611 }
612
613 s = scan_version(version, ver, qv);
614 if ( *s != '\0' )
615 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
616 "Version string '%s' contains invalid data; "
617 "ignoring: '%s'", version, s);
618 Safefree(version);
619 return ver;
620}
621
622/*
623=for apidoc vverify
624
625Validates that the SV contains valid internal structure for a version object.
626It may be passed either the version object (RV) or the hash itself (HV). If
627the structure is valid, it returns the HV. If the structure is invalid,
628it returns NULL.
629
630 SV *hv = vverify(sv);
631
632Note that it only confirms the bare minimum structure (so as not to get
633confused by derived classes which may contain additional hash entries):
634
635=over 4
636
637=item * The SV is an HV or a reference to an HV
638
639=item * The hash contains a "version" key
640
641=item * The "version" key has a reference to an AV as its value
642
643=back
644
645=cut
646*/
647
648SV *
649Perl_vverify(pTHX_ SV *vs)
650{
651 SV *sv;
652
653 PERL_ARGS_ASSERT_VVERIFY;
654
655 if ( SvROK(vs) )
656 vs = SvRV(vs);
657
658 /* see if the appropriate elements exist */
659 if ( SvTYPE(vs) == SVt_PVHV
660 && hv_exists(MUTABLE_HV(vs), "version", 7)
661 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
662 && SvTYPE(sv) == SVt_PVAV )
663 return vs;
664 else
665 return NULL;
666}
667
668/*
669=for apidoc vnumify
670
671Accepts a version object and returns the normalized floating
672point representation. Call like:
673
674 sv = vnumify(rv);
675
676NOTE: you can pass either the object directly or the SV
677contained within the RV.
678
679The SV returned has a refcount of 1.
680
681=cut
682*/
683
684SV *
685Perl_vnumify(pTHX_ SV *vs)
686{
687 SSize_t i, len;
688 I32 digit;
689 int width;
690 bool alpha = FALSE;
691 SV *sv;
692 AV *av;
693
694 PERL_ARGS_ASSERT_VNUMIFY;
695
696 /* extract the HV from the object */
697 vs = vverify(vs);
698 if ( ! vs )
699 Perl_croak(aTHX_ "Invalid version object");
700
701 /* see if various flags exist */
702 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
703 alpha = TRUE;
704 if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
705 width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
706 else
707 width = 3;
708
709
710 /* attempt to retrieve the version array */
711 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
712 return newSVpvs("0");
713 }
714
715 len = av_len(av);
716 if ( len == -1 )
717 {
718 return newSVpvs("0");
719 }
720
721 digit = SvIV(*av_fetch(av, 0, 0));
722 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
723 for ( i = 1 ; i < len ; i++ )
724 {
725 digit = SvIV(*av_fetch(av, i, 0));
726 if ( width < 3 ) {
727 const int denom = (width == 2 ? 10 : 100);
728 const div_t term = div((int)PERL_ABS(digit),denom);
729 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
730 }
731 else {
732 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
733 }
734 }
735
736 if ( len > 0 )
737 {
738 digit = SvIV(*av_fetch(av, len, 0));
739 if ( alpha && width == 3 ) /* alpha version */
740 sv_catpvs(sv,"_");
741 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
742 }
743 else /* len == 0 */
744 {
745 sv_catpvs(sv, "000");
746 }
747 return sv;
748}
749
750/*
751=for apidoc vnormal
752
753Accepts a version object and returns the normalized string
754representation. Call like:
755
756 sv = vnormal(rv);
757
758NOTE: you can pass either the object directly or the SV
759contained within the RV.
760
761The SV returned has a refcount of 1.
762
763=cut
764*/
765
766SV *
767Perl_vnormal(pTHX_ SV *vs)
768{
769 I32 i, len, digit;
770 bool alpha = FALSE;
771 SV *sv;
772 AV *av;
773
774 PERL_ARGS_ASSERT_VNORMAL;
775
776 /* extract the HV from the object */
777 vs = vverify(vs);
778 if ( ! vs )
779 Perl_croak(aTHX_ "Invalid version object");
780
781 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
782 alpha = TRUE;
783 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
784
785 len = av_len(av);
786 if ( len == -1 )
787 {
788 return newSVpvs("");
789 }
790 digit = SvIV(*av_fetch(av, 0, 0));
791 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
792 for ( i = 1 ; i < len ; i++ ) {
793 digit = SvIV(*av_fetch(av, i, 0));
794 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
795 }
796
797 if ( len > 0 )
798 {
799 /* handle last digit specially */
800 digit = SvIV(*av_fetch(av, len, 0));
801 if ( alpha )
802 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
803 else
804 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
805 }
806
807 if ( len <= 2 ) { /* short version, must be at least three */
808 for ( len = 2 - len; len != 0; len-- )
809 sv_catpvs(sv,".0");
810 }
811 return sv;
812}
813
814/*
815=for apidoc vstringify
816
817In order to maintain maximum compatibility with earlier versions
818of Perl, this function will return either the floating point
819notation or the multiple dotted notation, depending on whether
820the original version contained 1 or more dots, respectively.
821
822The SV returned has a refcount of 1.
823
824=cut
825*/
826
827SV *
828Perl_vstringify(pTHX_ SV *vs)
829{
830 PERL_ARGS_ASSERT_VSTRINGIFY;
831
832 /* extract the HV from the object */
833 vs = vverify(vs);
834 if ( ! vs )
835 Perl_croak(aTHX_ "Invalid version object");
836
837 if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
838 SV *pv;
839 pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
840 if ( SvPOK(pv) )
841 return newSVsv(pv);
842 else
843 return &PL_sv_undef;
844 }
845 else {
846 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
847 return vnormal(vs);
848 else
849 return vnumify(vs);
850 }
851}
852
853/*
854=for apidoc vcmp
855
856Version object aware cmp. Both operands must already have been
857converted into version objects.
858
859=cut
860*/
861
862int
863Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
864{
865 SSize_t i,l,m,r;
866 I32 retval;
867 bool lalpha = FALSE;
868 bool ralpha = FALSE;
869 I32 left = 0;
870 I32 right = 0;
871 AV *lav, *rav;
872
873 PERL_ARGS_ASSERT_VCMP;
874
875 /* extract the HVs from the objects */
876 lhv = vverify(lhv);
877 rhv = vverify(rhv);
878 if ( ! ( lhv && rhv ) )
879 Perl_croak(aTHX_ "Invalid version object");
880
881 /* get the left hand term */
882 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
883 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
884 lalpha = TRUE;
885
886 /* and the right hand term */
887 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
888 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
889 ralpha = TRUE;
890
891 l = av_len(lav);
892 r = av_len(rav);
893 m = l < r ? l : r;
894 retval = 0;
895 i = 0;
896 while ( i <= m && retval == 0 )
897 {
898 left = SvIV(*av_fetch(lav,i,0));
899 right = SvIV(*av_fetch(rav,i,0));
900 if ( left < right )
901 retval = -1;
902 if ( left > right )
903 retval = +1;
904 i++;
905 }
906
907 /* tiebreaker for alpha with identical terms */
908 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
909 {
910 if ( lalpha && !ralpha )
911 {
912 retval = -1;
913 }
914 else if ( ralpha && !lalpha)
915 {
916 retval = +1;
917 }
918 }
919
920 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
921 {
922 if ( l < r )
923 {
924 while ( i <= r && retval == 0 )
925 {
926 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
927 retval = -1; /* not a match after all */
928 i++;
929 }
930 }
931 else
932 {
933 while ( i <= l && retval == 0 )
934 {
935 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
936 retval = +1; /* not a match after all */
937 i++;
938 }
939 }
940 }
941 return retval;
942}