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