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