This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Lots of C optimizations for both speed/correctness
[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 4#ifndef PERL_CORE
05402f6b 5# define PERL_NO_GET_CONTEXT
d4e59e62
FC
6# include "EXTERN.h"
7# include "perl.h"
8# include "XSUB.h"
9# define NEED_my_snprintf
10# define NEED_newRV_noinc
11# define NEED_vnewSVpvf
12# define NEED_newSVpvn_flags_GLOBAL
13# define NEED_warner
14# include "ppport.h"
15#endif
16#include "vutil.h"
17
abc6d738
FC
18#define VERSION_MAX 0x7FFFFFFF
19
20/*
21=for apidoc prescan_version
22
23Validate that a given string can be parsed as a version object, but doesn't
24actually perform the parsing. Can use either strict or lax validation rules.
25Can optionally set a number of hint variables to save the parsing code
26some time when tokenizing.
27
28=cut
29*/
30const char *
d4e59e62
FC
31#if VUTIL_REPLACE_CORE
32Perl_prescan_version2(pTHX_ const char *s, bool strict,
33#else
abc6d738 34Perl_prescan_version(pTHX_ const char *s, bool strict,
d4e59e62 35#endif
abc6d738
FC
36 const char **errstr,
37 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
38 bool qv = (sqv ? *sqv : FALSE);
39 int width = 3;
40 int saw_decimal = 0;
41 bool alpha = FALSE;
42 const char *d = s;
43
44 PERL_ARGS_ASSERT_PRESCAN_VERSION;
45
46 if (qv && isDIGIT(*d))
47 goto dotted_decimal_version;
48
49 if (*d == 'v') { /* explicit v-string */
50 d++;
51 if (isDIGIT(*d)) {
52 qv = TRUE;
53 }
54 else { /* degenerate v-string */
55 /* requires v1.2.3 */
56 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
57 }
58
59dotted_decimal_version:
60 if (strict && d[0] == '0' && isDIGIT(d[1])) {
61 /* no leading zeros allowed */
62 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
63 }
64
65 while (isDIGIT(*d)) /* integer part */
66 d++;
67
68 if (*d == '.')
69 {
70 saw_decimal++;
71 d++; /* decimal point */
72 }
73 else
74 {
75 if (strict) {
76 /* require v1.2.3 */
77 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
78 }
79 else {
80 goto version_prescan_finish;
81 }
82 }
83
84 {
85 int i = 0;
86 int j = 0;
87 while (isDIGIT(*d)) { /* just keep reading */
88 i++;
89 while (isDIGIT(*d)) {
90 d++; j++;
91 /* maximum 3 digits between decimal */
92 if (strict && j > 3) {
93 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
94 }
95 }
96 if (*d == '_') {
97 if (strict) {
98 BADVERSION(s,errstr,"Invalid version format (no underscores)");
99 }
100 if ( alpha ) {
101 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
102 }
103 d++;
104 alpha = TRUE;
105 }
106 else if (*d == '.') {
107 if (alpha) {
108 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
109 }
110 saw_decimal++;
111 d++;
112 }
113 else if (!isDIGIT(*d)) {
114 break;
115 }
116 j = 0;
117 }
118
119 if (strict && i < 2) {
120 /* requires v1.2.3 */
121 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
122 }
123 }
124 } /* end if dotted-decimal */
125 else
126 { /* decimal versions */
127 int j = 0; /* may need this later */
128 /* special strict case for leading '.' or '0' */
129 if (strict) {
130 if (*d == '.') {
131 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
132 }
133 if (*d == '0' && isDIGIT(d[1])) {
134 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
135 }
136 }
137
138 /* and we never support negative versions */
139 if ( *d == '-') {
140 BADVERSION(s,errstr,"Invalid version format (negative version number)");
141 }
142
143 /* consume all of the integer part */
144 while (isDIGIT(*d))
145 d++;
146
147 /* look for a fractional part */
148 if (*d == '.') {
149 /* we found it, so consume it */
150 saw_decimal++;
151 d++;
152 }
153 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
154 if ( d == s ) {
155 /* found nothing */
156 BADVERSION(s,errstr,"Invalid version format (version required)");
157 }
158 /* found just an integer */
159 goto version_prescan_finish;
160 }
161 else if ( d == s ) {
162 /* didn't find either integer or period */
163 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
164 }
165 else if (*d == '_') {
166 /* underscore can't come after integer part */
167 if (strict) {
168 BADVERSION(s,errstr,"Invalid version format (no underscores)");
169 }
170 else if (isDIGIT(d[1])) {
171 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
172 }
173 else {
174 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
175 }
176 }
177 else {
178 /* anything else after integer part is just invalid data */
179 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
180 }
181
182 /* scan the fractional part after the decimal point*/
183
184 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
185 /* strict or lax-but-not-the-end */
186 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
187 }
188
189 while (isDIGIT(*d)) {
190 d++; j++;
191 if (*d == '.' && isDIGIT(d[-1])) {
192 if (alpha) {
193 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
194 }
195 if (strict) {
196 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
197 }
198 d = (char *)s; /* start all over again */
199 qv = TRUE;
200 goto dotted_decimal_version;
201 }
202 if (*d == '_') {
203 if (strict) {
204 BADVERSION(s,errstr,"Invalid version format (no underscores)");
205 }
206 if ( alpha ) {
207 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
208 }
209 if ( ! isDIGIT(d[1]) ) {
210 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
211 }
212 width = j;
213 d++;
214 alpha = TRUE;
215 }
216 }
217 }
218
219version_prescan_finish:
220 while (isSPACE(*d))
221 d++;
222
223 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
224 /* trailing non-numeric data */
225 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
226 }
227
228 if (sqv)
229 *sqv = qv;
230 if (swidth)
231 *swidth = width;
232 if (ssaw_decimal)
233 *ssaw_decimal = saw_decimal;
234 if (salpha)
235 *salpha = alpha;
236 return d;
237}
238
239/*
240=for apidoc scan_version
241
242Returns a pointer to the next character after the parsed
243version string, as well as upgrading the passed in SV to
244an RV.
245
246Function must be called with an already existing SV like
247
248 sv = newSV(0);
249 s = scan_version(s, SV *sv, bool qv);
250
251Performs some preprocessing to the string to ensure that
252it has the correct characteristics of a version. Flags the
253object if it contains an underscore (which denotes this
254is an alpha version). The boolean qv denotes that the version
255should be interpreted as if it had multiple decimals, even if
256it doesn't.
257
258=cut
259*/
260
261const char *
d4e59e62
FC
262#if VUTIL_REPLACE_CORE
263Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
264#else
abc6d738 265Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
d4e59e62 266#endif
abc6d738
FC
267{
268 const char *start = s;
269 const char *pos;
270 const char *last;
271 const char *errstr = NULL;
272 int saw_decimal = 0;
273 int width = 3;
274 bool alpha = FALSE;
275 bool vinf = FALSE;
276 AV * av;
277 SV * hv;
278
279 PERL_ARGS_ASSERT_SCAN_VERSION;
280
281 while (isSPACE(*s)) /* leading whitespace is OK */
282 s++;
283
d4e59e62 284 last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
abc6d738
FC
285 if (errstr) {
286 /* "undef" is a special case and not an error */
05402f6b 287 if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
abc6d738
FC
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*/
05402f6b 399 SSize_t len = AvFILLp(av);
abc6d738
FC
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 */
05402f6b 435 if ( *s == 'u' && strEQ(s+1,"ndef") ) {
abc6d738
FC
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;
05402f6b 465 if ( ISA_VERSION_OBJ(ver) ) /* 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));
abc6d738 486 {
05402f6b
JP
487 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
488 if(svp) {
489 const I32 width = SvIV(*svp);
490 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
491 }
abc6d738 492 }
abc6d738 493 {
05402f6b
JP
494 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
495 if(svp)
496 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
abc6d738 497 }
abc6d738
FC
498 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
499 /* This will get reblessed later if a derived class*/
500 for ( key = 0; key <= av_len(sav); key++ )
501 {
05402f6b
JP
502 SV * const sv = *av_fetch(sav, key, FALSE);
503 const I32 rev = SvIV(sv);
abc6d738
FC
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;
05402f6b 515 const char * const version = (const char*)mg->mg_ptr;
abc6d738
FC
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);
abc6d738
FC
520 }
521 else {
522#endif
95a23f5d 523 SvSetSV_nosteal(rv, ver); /* make a duplicate */
abc6d738
FC
524#ifdef SvVOK
525 }
526 }
527#endif
d4e59e62 528 return UPG_VERSION(rv, FALSE);
abc6d738
FC
529}
530
531/*
532=for apidoc upg_version
533
534In-place upgrade of the supplied SV to a version object.
535
536 SV *sv = upg_version(SV *sv, bool qv);
537
538Returns a pointer to the upgraded SV. Set the boolean qv if you want
539to force this SV to be interpreted as an "extended" version.
540
541=cut
542*/
543
544SV *
d4e59e62
FC
545#if VUTIL_REPLACE_CORE
546Perl_upg_version2(pTHX_ SV *ver, bool qv)
547#else
abc6d738 548Perl_upg_version(pTHX_ SV *ver, bool qv)
d4e59e62 549#endif
abc6d738
FC
550{
551 const char *version, *s;
552#ifdef SvVOK
553 const MAGIC *mg;
554#endif
555
556 PERL_ARGS_ASSERT_UPG_VERSION;
557
05402f6b 558 if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
abc6d738
FC
559 {
560 STRLEN len;
561
562 /* may get too much accuracy */
563 char tbuf[64];
564 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
565 char *buf;
90d6b40e 566 STORE_NUMERIC_LOCAL_SET_STANDARD();
abc6d738 567 if (sv) {
ab4e0d4b
JP
568 Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
569 len = SvCUR(sv);
570 buf = SvPVX(sv);
abc6d738
FC
571 }
572 else {
573 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
574 buf = tbuf;
575 }
90d6b40e 576 RESTORE_NUMERIC_LOCAL();
abc6d738
FC
577 while (buf[len-1] == '0' && len > 0) len--;
578 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
579 version = savepvn(buf, len);
05402f6b 580 SAVEFREEPV(version);
abc6d738
FC
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 );
05402f6b 586 SAVEFREEPV(version);
abc6d738
FC
587 qv = TRUE;
588 }
589#endif
4141ef59
JP
590 else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
591 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
95a23f5d 592 /* out of bounds [unsigned] integer */
4141ef59
JP
593 STRLEN len;
594 char tbuf[64];
595 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
596 version = savepvn(tbuf, len);
05402f6b 597 SAVEFREEPV(version);
4141ef59
JP
598 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
599 "Integer overflow in version %d",VERSION_MAX);
600 }
95a23f5d
JP
601 else if ( SvUOK(ver) || SvIOK(ver) ) {
602 version = savesvpv(ver);
05402f6b 603 SAVEFREEPV(version);
95a23f5d 604 }
ab4e0d4b 605 else if ( SvPOK(ver) )/* must be a string or something like a string */
abc6d738
FC
606 {
607 STRLEN len;
4141ef59 608 version = savepvn(SvPV(ver,len), SvCUR(ver));
05402f6b 609 SAVEFREEPV(version);
abc6d738
FC
610#ifndef SvVOK
611# if PERL_VERSION > 5
612 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
613 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
614 /* may be a v-string */
615 char *testv = (char *)version;
616 STRLEN tlen = len;
617 for (tlen=0; tlen < len; tlen++, testv++) {
618 /* if one of the characters is non-text assume v-string */
619 if (testv[0] < ' ') {
620 SV * const nsv = sv_newmortal();
621 const char *nver;
622 const char *pos;
623 int saw_decimal = 0;
624 sv_setpvf(nsv,"v%vd",ver);
625 pos = nver = savepv(SvPV_nolen(nsv));
05402f6b 626 SAVEFREEPV(pos);
abc6d738
FC
627
628 /* scan the resulting formatted string */
629 pos++; /* skip the leading 'v' */
630 while ( *pos == '.' || isDIGIT(*pos) ) {
631 if ( *pos == '.' )
632 saw_decimal++ ;
633 pos++;
634 }
635
636 /* is definitely a v-string */
637 if ( saw_decimal >= 2 ) {
abc6d738
FC
638 version = nver;
639 }
640 break;
641 }
642 }
643 }
644# endif
645#endif
646 }
ab4e0d4b
JP
647 else
648 {
649 /* no idea what this is */
650 Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
651 }
abc6d738 652
d4e59e62 653 s = SCAN_VERSION(version, ver, qv);
abc6d738
FC
654 if ( *s != '\0' )
655 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
656 "Version string '%s' contains invalid data; "
657 "ignoring: '%s'", version, s);
abc6d738
FC
658 return ver;
659}
660
661/*
662=for apidoc vverify
663
664Validates that the SV contains valid internal structure for a version object.
665It may be passed either the version object (RV) or the hash itself (HV). If
666the structure is valid, it returns the HV. If the structure is invalid,
667it returns NULL.
668
669 SV *hv = vverify(sv);
670
671Note that it only confirms the bare minimum structure (so as not to get
672confused by derived classes which may contain additional hash entries):
673
674=over 4
675
676=item * The SV is an HV or a reference to an HV
677
678=item * The hash contains a "version" key
679
680=item * The "version" key has a reference to an AV as its value
681
682=back
683
684=cut
685*/
686
687SV *
d4e59e62
FC
688#if VUTIL_REPLACE_CORE
689Perl_vverify2(pTHX_ SV *vs)
690#else
abc6d738 691Perl_vverify(pTHX_ SV *vs)
d4e59e62 692#endif
abc6d738
FC
693{
694 SV *sv;
05402f6b 695 SV **svp;
abc6d738
FC
696
697 PERL_ARGS_ASSERT_VVERIFY;
698
699 if ( SvROK(vs) )
700 vs = SvRV(vs);
701
702 /* see if the appropriate elements exist */
703 if ( SvTYPE(vs) == SVt_PVHV
05402f6b
JP
704 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
705 && (sv = SvRV(*svp))
abc6d738
FC
706 && SvTYPE(sv) == SVt_PVAV )
707 return vs;
708 else
709 return NULL;
710}
711
712/*
713=for apidoc vnumify
714
715Accepts a version object and returns the normalized floating
716point representation. Call like:
717
718 sv = vnumify(rv);
719
720NOTE: you can pass either the object directly or the SV
721contained within the RV.
722
723The SV returned has a refcount of 1.
724
725=cut
726*/
727
728SV *
d4e59e62
FC
729#if VUTIL_REPLACE_CORE
730Perl_vnumify2(pTHX_ SV *vs)
731#else
abc6d738 732Perl_vnumify(pTHX_ SV *vs)
d4e59e62 733#endif
abc6d738
FC
734{
735 SSize_t i, len;
736 I32 digit;
737 int width;
738 bool alpha = FALSE;
739 SV *sv;
740 AV *av;
741
742 PERL_ARGS_ASSERT_VNUMIFY;
743
744 /* extract the HV from the object */
d4e59e62 745 vs = VVERIFY(vs);
abc6d738
FC
746 if ( ! vs )
747 Perl_croak(aTHX_ "Invalid version object");
748
749 /* see if various flags exist */
750 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
751 alpha = TRUE;
05402f6b
JP
752 {
753 SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
754 if ( svp )
755 width = SvIV(*svp);
756 else
757 width = 3;
758 }
abc6d738
FC
759
760
761 /* attempt to retrieve the version array */
762 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
763 return newSVpvs("0");
764 }
765
766 len = av_len(av);
767 if ( len == -1 )
768 {
769 return newSVpvs("0");
770 }
771
05402f6b
JP
772 {
773 SV * tsv = *av_fetch(av, 0, 0);
774 digit = SvIV(tsv);
775 }
abc6d738
FC
776 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
777 for ( i = 1 ; i < len ; i++ )
778 {
05402f6b
JP
779 SV * tsv = *av_fetch(av, i, 0);
780 digit = SvIV(tsv);
abc6d738
FC
781 if ( width < 3 ) {
782 const int denom = (width == 2 ? 10 : 100);
783 const div_t term = div((int)PERL_ABS(digit),denom);
784 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
785 }
786 else {
787 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
788 }
789 }
790
791 if ( len > 0 )
792 {
05402f6b
JP
793 SV * tsv = *av_fetch(av, len, 0);
794 digit = SvIV(tsv);
abc6d738
FC
795 if ( alpha && width == 3 ) /* alpha version */
796 sv_catpvs(sv,"_");
797 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
798 }
799 else /* len == 0 */
800 {
801 sv_catpvs(sv, "000");
802 }
803 return sv;
804}
805
806/*
807=for apidoc vnormal
808
809Accepts a version object and returns the normalized string
810representation. Call like:
811
812 sv = vnormal(rv);
813
814NOTE: you can pass either the object directly or the SV
815contained within the RV.
816
817The SV returned has a refcount of 1.
818
819=cut
820*/
821
822SV *
d4e59e62
FC
823#if VUTIL_REPLACE_CORE
824Perl_vnormal2(pTHX_ SV *vs)
825#else
abc6d738 826Perl_vnormal(pTHX_ SV *vs)
d4e59e62 827#endif
abc6d738
FC
828{
829 I32 i, len, digit;
830 bool alpha = FALSE;
831 SV *sv;
832 AV *av;
833
834 PERL_ARGS_ASSERT_VNORMAL;
835
836 /* extract the HV from the object */
d4e59e62 837 vs = VVERIFY(vs);
abc6d738
FC
838 if ( ! vs )
839 Perl_croak(aTHX_ "Invalid version object");
840
841 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
842 alpha = TRUE;
843 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
844
845 len = av_len(av);
846 if ( len == -1 )
847 {
848 return newSVpvs("");
849 }
05402f6b
JP
850 {
851 SV * tsv = *av_fetch(av, 0, 0);
852 digit = SvIV(tsv);
853 }
abc6d738
FC
854 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
855 for ( i = 1 ; i < len ; i++ ) {
05402f6b
JP
856 SV * tsv = *av_fetch(av, i, 0);
857 digit = SvIV(tsv);
abc6d738
FC
858 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
859 }
860
861 if ( len > 0 )
862 {
863 /* handle last digit specially */
05402f6b
JP
864 SV * tsv = *av_fetch(av, len, 0);
865 digit = SvIV(tsv);
abc6d738
FC
866 if ( alpha )
867 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
868 else
869 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
870 }
871
872 if ( len <= 2 ) { /* short version, must be at least three */
873 for ( len = 2 - len; len != 0; len-- )
874 sv_catpvs(sv,".0");
875 }
876 return sv;
877}
878
879/*
880=for apidoc vstringify
881
882In order to maintain maximum compatibility with earlier versions
883of Perl, this function will return either the floating point
884notation or the multiple dotted notation, depending on whether
885the original version contained 1 or more dots, respectively.
886
887The SV returned has a refcount of 1.
888
889=cut
890*/
891
892SV *
d4e59e62
FC
893#if VUTIL_REPLACE_CORE
894Perl_vstringify2(pTHX_ SV *vs)
895#else
abc6d738 896Perl_vstringify(pTHX_ SV *vs)
d4e59e62 897#endif
abc6d738 898{
05402f6b 899 SV ** svp;
abc6d738
FC
900 PERL_ARGS_ASSERT_VSTRINGIFY;
901
902 /* extract the HV from the object */
d4e59e62 903 vs = VVERIFY(vs);
abc6d738
FC
904 if ( ! vs )
905 Perl_croak(aTHX_ "Invalid version object");
906
05402f6b
JP
907 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
908 if (svp) {
abc6d738 909 SV *pv;
05402f6b 910 pv = *svp;
abc6d738
FC
911 if ( SvPOK(pv) )
912 return newSVsv(pv);
913 else
914 return &PL_sv_undef;
915 }
916 else {
917 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
d4e59e62 918 return VNORMAL(vs);
abc6d738 919 else
d4e59e62 920 return VNUMIFY(vs);
abc6d738
FC
921 }
922}
923
924/*
925=for apidoc vcmp
926
927Version object aware cmp. Both operands must already have been
928converted into version objects.
929
930=cut
931*/
932
933int
d4e59e62
FC
934#if VUTIL_REPLACE_CORE
935Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
936#else
abc6d738 937Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
d4e59e62 938#endif
abc6d738
FC
939{
940 SSize_t i,l,m,r;
941 I32 retval;
942 bool lalpha = FALSE;
943 bool ralpha = FALSE;
944 I32 left = 0;
945 I32 right = 0;
946 AV *lav, *rav;
947
948 PERL_ARGS_ASSERT_VCMP;
949
950 /* extract the HVs from the objects */
d4e59e62
FC
951 lhv = VVERIFY(lhv);
952 rhv = VVERIFY(rhv);
abc6d738
FC
953 if ( ! ( lhv && rhv ) )
954 Perl_croak(aTHX_ "Invalid version object");
955
956 /* get the left hand term */
957 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
958 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
959 lalpha = TRUE;
960
961 /* and the right hand term */
962 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
963 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
964 ralpha = TRUE;
965
966 l = av_len(lav);
967 r = av_len(rav);
968 m = l < r ? l : r;
969 retval = 0;
970 i = 0;
971 while ( i <= m && retval == 0 )
972 {
05402f6b
JP
973 SV * const lsv = *av_fetch(lav,i,0);
974 SV * rsv;
975 left = SvIV(lsv);
976 rsv = *av_fetch(rav,i,0);
977 right = SvIV(rsv);
abc6d738
FC
978 if ( left < right )
979 retval = -1;
980 if ( left > right )
981 retval = +1;
982 i++;
983 }
984
985 /* tiebreaker for alpha with identical terms */
986 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
987 {
988 if ( lalpha && !ralpha )
989 {
990 retval = -1;
991 }
992 else if ( ralpha && !lalpha)
993 {
994 retval = +1;
995 }
996 }
997
998 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
999 {
1000 if ( l < r )
1001 {
1002 while ( i <= r && retval == 0 )
1003 {
05402f6b
JP
1004 SV * const rsv = *av_fetch(rav,i,0);
1005 if ( SvIV(rsv) != 0 )
abc6d738
FC
1006 retval = -1; /* not a match after all */
1007 i++;
1008 }
1009 }
1010 else
1011 {
1012 while ( i <= l && retval == 0 )
1013 {
05402f6b
JP
1014 SV * const lsv = *av_fetch(lav,i,0);
1015 if ( SvIV(lsv) != 0 )
abc6d738
FC
1016 retval = +1; /* not a match after all */
1017 i++;
1018 }
1019 }
1020 }
1021 return retval;
1022}