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