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