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