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