This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlguts: Document UTF8f format
[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);
2324bdb9 536 SvCUR_set(rv, SvCUR(rv) - 1);
14f3031b
JP
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 573{
8633b539
DM
574
575#ifdef dVAR
576 dVAR;
577#endif
578
abc6d738
FC
579 const char *version, *s;
580#ifdef SvVOK
581 const MAGIC *mg;
582#endif
583
d2b110e6 584#if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
e2ca569e 585 ENTER;
d2b110e6 586#endif
abc6d738
FC
587 PERL_ARGS_ASSERT_UPG_VERSION;
588
9190f8ab
JP
589 if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
590 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
591 /* out of bounds [unsigned] integer */
592 STRLEN len;
593 char tbuf[64];
594 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
595 version = savepvn(tbuf, len);
596 SAVEFREEPV(version);
597 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
598 "Integer overflow in version %d",VERSION_MAX);
599 }
600 else if ( SvUOK(ver) || SvIOK(ver))
24120986 601#if PERL_VERSION_LT(5,17,2)
9190f8ab 602VER_IV:
24120986 603#endif
9190f8ab
JP
604 {
605 version = savesvpv(ver);
606 SAVEFREEPV(version);
607 }
608 else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
24120986 609#if PERL_VERSION_LT(5,17,2)
9190f8ab 610VER_NV:
24120986 611#endif
abc6d738
FC
612 {
613 STRLEN len;
614
615 /* may get too much accuracy */
616 char tbuf[64];
617 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
618 char *buf;
14f3031b
JP
619
620#if PERL_VERSION_GE(5,19,0)
621 if (SvPOK(ver)) {
622 /* dualvar? */
623 goto VER_PV;
624 }
625#endif
f57000bc 626#ifdef USE_LOCALE_NUMERIC
190ce35b 627
d3a5b29c 628 {
190ce35b
KW
629 /* This may or may not be called from code that has switched
630 * locales without letting perl know, therefore we have to find it
631 * from first principals. See [perl #121930]. */
632
e9bc6d6b
KW
633 /* In windows, or not threaded, or not thread-safe, if it isn't C,
634 * set it to C. */
635
636# ifndef USE_POSIX_2008_LOCALE
637
190ce35b
KW
638 const char * locale_name_on_entry;
639
49d7d366
KW
640 LC_NUMERIC_LOCK(0); /* Start critical section */
641
190ce35b
KW
642 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
643 if ( strNE(locale_name_on_entry, "C")
644 && strNE(locale_name_on_entry, "POSIX"))
645 {
646 setlocale(LC_NUMERIC, "C");
647 }
648 else { /* This value indicates to the restore code that we didn't
649 change the locale */
650 locale_name_on_entry = NULL;
651 }
49d7d366 652
e9bc6d6b
KW
653# else
654
655 const locale_t locale_obj_on_entry = uselocale((locale_t) 0);
656 const char * locale_name_on_entry = NULL;
657 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
658
659 if (locale_obj_on_entry == LC_GLOBAL_LOCALE) {
660
661 /* in the global locale, we can call system setlocale and if it
662 * isn't C, set it to C. */
663 LC_NUMERIC_LOCK(0);
664
665 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
666 if ( strNE(locale_name_on_entry, "C")
667 && strNE(locale_name_on_entry, "POSIX"))
668 {
669 setlocale(LC_NUMERIC, "C");
670 }
671 else { /* This value indicates to the restore code that we
672 didn't change the locale */
673 locale_name_on_entry = NULL;
d3a5b29c
JP
674 }
675 }
e9bc6d6b
KW
676 else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
677 /* Here, the locale appears to have been changed to use the
678 * program's underlying locale. Just use our mechanisms to
679 * switch back to C. It might be possible for this pointer to
680 * actually refer to something else if it got released and
681 * reused somehow. But it doesn't matter, our mechanisms will
682 * work even so */
683 STORE_LC_NUMERIC_SET_STANDARD();
684 }
685 else if (locale_obj_on_entry != PL_C_locale_obj) {
686 /* The C object should be unchanged during a program's
687 * execution, so it should be safe to assume it means what it
688 * says, so if we are in it, no locale change is required.
689 * Otherwise, simply use the thread-safe operation. */
690 uselocale(PL_C_locale_obj);
691 }
692
693# endif
694
190ce35b
KW
695 /* Prevent recursed calls from trying to change back */
696 LOCK_LC_NUMERIC_STANDARD();
697
f57000bc 698#endif
190ce35b 699
d3a5b29c 700 if (sv) {
a6842133 701 Perl_sv_catpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver));
d3a5b29c
JP
702 len = SvCUR(sv);
703 buf = SvPVX(sv);
704 }
705 else {
a6842133 706 len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver));
d3a5b29c
JP
707 buf = tbuf;
708 }
190ce35b
KW
709
710#ifdef USE_LOCALE_NUMERIC
711
712 UNLOCK_LC_NUMERIC_STANDARD();
713
e9bc6d6b
KW
714# ifndef USE_POSIX_2008_LOCALE
715
190ce35b
KW
716 if (locale_name_on_entry) {
717 setlocale(LC_NUMERIC, locale_name_on_entry);
718 }
49d7d366
KW
719
720 LC_NUMERIC_UNLOCK; /* End critical section */
721
e9bc6d6b
KW
722# else
723
724 if (locale_name_on_entry) {
725 setlocale(LC_NUMERIC, locale_name_on_entry);
726 LC_NUMERIC_UNLOCK;
727 }
728 else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
729 RESTORE_LC_NUMERIC();
730 }
731 else if (locale_obj_on_entry != PL_C_locale_obj) {
732 uselocale(locale_obj_on_entry);
d3a5b29c 733 }
e9bc6d6b
KW
734
735# endif
736
f57000bc 737 }
190ce35b
KW
738
739#endif /* USE_LOCALE_NUMERIC */
740
abc6d738
FC
741 while (buf[len-1] == '0' && len > 0) len--;
742 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
743 version = savepvn(buf, len);
05402f6b 744 SAVEFREEPV(version);
abc6d738
FC
745 SvREFCNT_dec(sv);
746 }
747#ifdef SvVOK
748 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
749 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
05402f6b 750 SAVEFREEPV(version);
abc6d738
FC
751 qv = TRUE;
752 }
753#endif
9190f8ab
JP
754 else if ( SvPOK(ver))/* must be a string or something like a string */
755VER_PV:
abc6d738
FC
756 {
757 STRLEN len;
4141ef59 758 version = savepvn(SvPV(ver,len), SvCUR(ver));
05402f6b 759 SAVEFREEPV(version);
abc6d738
FC
760#ifndef SvVOK
761# if PERL_VERSION > 5
762 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
763 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
764 /* may be a v-string */
765 char *testv = (char *)version;
766 STRLEN tlen = len;
767 for (tlen=0; tlen < len; tlen++, testv++) {
768 /* if one of the characters is non-text assume v-string */
769 if (testv[0] < ' ') {
770 SV * const nsv = sv_newmortal();
771 const char *nver;
772 const char *pos;
773 int saw_decimal = 0;
774 sv_setpvf(nsv,"v%vd",ver);
775 pos = nver = savepv(SvPV_nolen(nsv));
05402f6b 776 SAVEFREEPV(pos);
abc6d738
FC
777
778 /* scan the resulting formatted string */
779 pos++; /* skip the leading 'v' */
780 while ( *pos == '.' || isDIGIT(*pos) ) {
781 if ( *pos == '.' )
782 saw_decimal++ ;
783 pos++;
784 }
785
786 /* is definitely a v-string */
787 if ( saw_decimal >= 2 ) {
abc6d738
FC
788 version = nver;
789 }
790 break;
791 }
792 }
793 }
794# endif
795#endif
796 }
9190f8ab
JP
797#if PERL_VERSION_LT(5,17,2)
798 else if (SvIOKp(ver)) {
799 goto VER_IV;
800 }
801 else if (SvNOKp(ver)) {
802 goto VER_NV;
803 }
804 else if (SvPOKp(ver)) {
805 goto VER_PV;
806 }
807#endif
ab4e0d4b
JP
808 else
809 {
810 /* no idea what this is */
811 Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
812 }
abc6d738 813
d4e59e62 814 s = SCAN_VERSION(version, ver, qv);
abc6d738
FC
815 if ( *s != '\0' )
816 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
817 "Version string '%s' contains invalid data; "
818 "ignoring: '%s'", version, s);
d2b110e6
JP
819
820#if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
e2ca569e 821 LEAVE;
d2b110e6 822#endif
9190f8ab 823
abc6d738
FC
824 return ver;
825}
826
827/*
828=for apidoc vverify
829
830Validates that the SV contains valid internal structure for a version object.
831It may be passed either the version object (RV) or the hash itself (HV). If
832the structure is valid, it returns the HV. If the structure is invalid,
833it returns NULL.
834
835 SV *hv = vverify(sv);
836
837Note that it only confirms the bare minimum structure (so as not to get
838confused by derived classes which may contain additional hash entries):
839
840=over 4
841
842=item * The SV is an HV or a reference to an HV
843
844=item * The hash contains a "version" key
845
846=item * The "version" key has a reference to an AV as its value
847
848=back
849
850=cut
851*/
852
853SV *
24120986 854#ifdef VUTIL_REPLACE_CORE
d4e59e62
FC
855Perl_vverify2(pTHX_ SV *vs)
856#else
abc6d738 857Perl_vverify(pTHX_ SV *vs)
d4e59e62 858#endif
abc6d738
FC
859{
860 SV *sv;
05402f6b 861 SV **svp;
abc6d738
FC
862
863 PERL_ARGS_ASSERT_VVERIFY;
864
865 if ( SvROK(vs) )
866 vs = SvRV(vs);
867
868 /* see if the appropriate elements exist */
869 if ( SvTYPE(vs) == SVt_PVHV
05402f6b
JP
870 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
871 && (sv = SvRV(*svp))
abc6d738
FC
872 && SvTYPE(sv) == SVt_PVAV )
873 return vs;
874 else
875 return NULL;
876}
877
878/*
879=for apidoc vnumify
880
881Accepts a version object and returns the normalized floating
882point representation. Call like:
883
884 sv = vnumify(rv);
885
886NOTE: you can pass either the object directly or the SV
887contained within the RV.
888
889The SV returned has a refcount of 1.
890
891=cut
892*/
893
894SV *
24120986 895#ifdef VUTIL_REPLACE_CORE
d4e59e62
FC
896Perl_vnumify2(pTHX_ SV *vs)
897#else
abc6d738 898Perl_vnumify(pTHX_ SV *vs)
d4e59e62 899#endif
abc6d738
FC
900{
901 SSize_t i, len;
902 I32 digit;
abc6d738
FC
903 bool alpha = FALSE;
904 SV *sv;
905 AV *av;
906
907 PERL_ARGS_ASSERT_VNUMIFY;
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 /* see if various flags exist */
817794ed 915 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
abc6d738 916 alpha = TRUE;
abc6d738 917
14f3031b
JP
918 if (alpha) {
919 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
920 "alpha->numify() is lossy");
921 }
abc6d738
FC
922
923 /* attempt to retrieve the version array */
924 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
925 return newSVpvs("0");
926 }
927
928 len = av_len(av);
929 if ( len == -1 )
930 {
931 return newSVpvs("0");
932 }
933
05402f6b
JP
934 {
935 SV * tsv = *av_fetch(av, 0, 0);
936 digit = SvIV(tsv);
937 }
abc6d738 938 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
14f3031b 939 for ( i = 1 ; i <= len ; i++ )
abc6d738 940 {
05402f6b
JP
941 SV * tsv = *av_fetch(av, i, 0);
942 digit = SvIV(tsv);
14f3031b 943 Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
abc6d738
FC
944 }
945
14f3031b 946 if ( len == 0 ) {
abc6d738
FC
947 sv_catpvs(sv, "000");
948 }
949 return sv;
950}
951
952/*
953=for apidoc vnormal
954
955Accepts a version object and returns the normalized string
956representation. Call like:
957
958 sv = vnormal(rv);
959
960NOTE: you can pass either the object directly or the SV
961contained within the RV.
962
963The SV returned has a refcount of 1.
964
965=cut
966*/
967
968SV *
24120986 969#ifdef VUTIL_REPLACE_CORE
d4e59e62
FC
970Perl_vnormal2(pTHX_ SV *vs)
971#else
abc6d738 972Perl_vnormal(pTHX_ SV *vs)
d4e59e62 973#endif
abc6d738
FC
974{
975 I32 i, len, digit;
abc6d738
FC
976 SV *sv;
977 AV *av;
978
979 PERL_ARGS_ASSERT_VNORMAL;
980
981 /* extract the HV from the object */
d4e59e62 982 vs = VVERIFY(vs);
abc6d738
FC
983 if ( ! vs )
984 Perl_croak(aTHX_ "Invalid version object");
985
abc6d738
FC
986 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
987
988 len = av_len(av);
989 if ( len == -1 )
990 {
991 return newSVpvs("");
992 }
05402f6b
JP
993 {
994 SV * tsv = *av_fetch(av, 0, 0);
995 digit = SvIV(tsv);
996 }
a6842133 997 sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit);
14f3031b 998 for ( i = 1 ; i <= len ; i++ ) {
05402f6b
JP
999 SV * tsv = *av_fetch(av, i, 0);
1000 digit = SvIV(tsv);
a6842133 1001 Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit);
abc6d738
FC
1002 }
1003
abc6d738
FC
1004 if ( len <= 2 ) { /* short version, must be at least three */
1005 for ( len = 2 - len; len != 0; len-- )
1006 sv_catpvs(sv,".0");
1007 }
1008 return sv;
1009}
1010
1011/*
1012=for apidoc vstringify
1013
1014In order to maintain maximum compatibility with earlier versions
1015of Perl, this function will return either the floating point
1016notation or the multiple dotted notation, depending on whether
1017the original version contained 1 or more dots, respectively.
1018
1019The SV returned has a refcount of 1.
1020
1021=cut
1022*/
1023
1024SV *
24120986 1025#ifdef VUTIL_REPLACE_CORE
d4e59e62
FC
1026Perl_vstringify2(pTHX_ SV *vs)
1027#else
abc6d738 1028Perl_vstringify(pTHX_ SV *vs)
d4e59e62 1029#endif
abc6d738 1030{
05402f6b 1031 SV ** svp;
abc6d738
FC
1032 PERL_ARGS_ASSERT_VSTRINGIFY;
1033
1034 /* extract the HV from the object */
d4e59e62 1035 vs = VVERIFY(vs);
abc6d738
FC
1036 if ( ! vs )
1037 Perl_croak(aTHX_ "Invalid version object");
1038
05402f6b
JP
1039 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
1040 if (svp) {
abc6d738 1041 SV *pv;
05402f6b 1042 pv = *svp;
dddb2275
JP
1043 if ( SvPOK(pv)
1044#if PERL_VERSION_LT(5,17,2)
1045 || SvPOKp(pv)
1046#endif
1047 )
abc6d738
FC
1048 return newSVsv(pv);
1049 else
1050 return &PL_sv_undef;
1051 }
1052 else {
817794ed 1053 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
d4e59e62 1054 return VNORMAL(vs);
abc6d738 1055 else
d4e59e62 1056 return VNUMIFY(vs);
abc6d738
FC
1057 }
1058}
1059
1060/*
1061=for apidoc vcmp
1062
1063Version object aware cmp. Both operands must already have been
1064converted into version objects.
1065
1066=cut
1067*/
1068
1069int
24120986 1070#ifdef VUTIL_REPLACE_CORE
d4e59e62
FC
1071Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1072#else
abc6d738 1073Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
d4e59e62 1074#endif
abc6d738
FC
1075{
1076 SSize_t i,l,m,r;
1077 I32 retval;
abc6d738
FC
1078 I32 left = 0;
1079 I32 right = 0;
1080 AV *lav, *rav;
1081
1082 PERL_ARGS_ASSERT_VCMP;
1083
1084 /* extract the HVs from the objects */
d4e59e62
FC
1085 lhv = VVERIFY(lhv);
1086 rhv = VVERIFY(rhv);
abc6d738
FC
1087 if ( ! ( lhv && rhv ) )
1088 Perl_croak(aTHX_ "Invalid version object");
1089
1090 /* get the left hand term */
1091 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
abc6d738
FC
1092
1093 /* and the right hand term */
1094 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
abc6d738
FC
1095
1096 l = av_len(lav);
1097 r = av_len(rav);
1098 m = l < r ? l : r;
1099 retval = 0;
1100 i = 0;
1101 while ( i <= m && retval == 0 )
1102 {
05402f6b
JP
1103 SV * const lsv = *av_fetch(lav,i,0);
1104 SV * rsv;
1105 left = SvIV(lsv);
1106 rsv = *av_fetch(rav,i,0);
1107 right = SvIV(rsv);
abc6d738
FC
1108 if ( left < right )
1109 retval = -1;
1110 if ( left > right )
1111 retval = +1;
1112 i++;
1113 }
1114
abc6d738
FC
1115 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1116 {
1117 if ( l < r )
1118 {
1119 while ( i <= r && retval == 0 )
1120 {
05402f6b
JP
1121 SV * const rsv = *av_fetch(rav,i,0);
1122 if ( SvIV(rsv) != 0 )
abc6d738
FC
1123 retval = -1; /* not a match after all */
1124 i++;
1125 }
1126 }
1127 else
1128 {
1129 while ( i <= l && retval == 0 )
1130 {
05402f6b
JP
1131 SV * const lsv = *av_fetch(lav,i,0);
1132 if ( SvIV(lsv) != 0 )
abc6d738
FC
1133 retval = +1; /* not a match after all */
1134 i++;
1135 }
1136 }
1137 }
1138 return retval;
1139}
14f3031b
JP
1140
1141/* ex: set ro: */