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