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 /*
11 =for apidoc prescan_version
12
13 Validate that a given string can be parsed as a version object, but doesn't
14 actually perform the parsing. Can use either strict or lax validation rules.
15 Can optionally set a number of hint variables to save the parsing code
16 some time when tokenizing.
17
18 =cut
19 */
20 const char *
21 #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)22 Perl_prescan_version2(pTHX_ const char *s, bool strict,
23 #else
24 Perl_prescan_version(pTHX_ const char *s, bool strict,
25 #endif
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
34 PERL_ARGS_ASSERT_PRESCAN_VERSION;
35 PERL_UNUSED_CONTEXT;
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
50 dotted_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
210 version_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 }
218 if (saw_decimal > 1 && d[-1] == '.') {
219 /* no trailing period allowed */
220 BADVERSION(s,errstr,"Invalid version format (trailing decimal)");
221 }
222
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
238 Returns a pointer to the next character after the parsed
239 version string, as well as upgrading the passed in SV to
240 an RV.
241
242 Function must be called with an already existing SV like
243
244 sv = newSV(0);
245 s = scan_version(s, SV *sv, bool qv);
246
247 Performs some preprocessing to the string to ensure that
248 it has the correct characteristics of a version. Flags the
249 object if it contains an underscore (which denotes this
250 is an alpha version). The boolean qv denotes that the version
251 should be interpreted as if it had multiple decimals, even if
252 it doesn't.
253
254 =cut
255 */
256
257 const char *
258 #ifdef VUTIL_REPLACE_CORE
Perl_scan_version2(pTHX_ const char * s,SV * rv,bool qv)259 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
260 #else
261 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
262 #endif
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
280 last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
281 if (errstr) {
282 /* "undef" is a special case and not an error */
283 if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
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
309 while (isDIGIT(*pos) || *pos == '_')
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 ) {
329 if (*s == '_')
330 continue;
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) {
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 {
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 }
363 else
364 rev += i * mult;
365
366 if (mult > VERSION_MAX / 10)
367 mult = VERSION_MAX;
368 else
369 mult *= 10;
370 }
371 }
372 }
373
374 /* Append revision */
375 av_push(av, newSViv(rev));
376 if ( vinf ) {
377 s = last;
378 break;
379 }
380 else if ( *pos == '.' ) {
381 pos++;
382 if (qv) {
383 while (*pos == '0')
384 ++pos;
385 }
386 s = pos;
387 }
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 ) {
399 while ( isDIGIT(*pos) || *pos == '_')
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*/
413 SSize_t len = AvFILLp(av);
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 */
449 if ( *s == 'u' && strEQ(s+1,"ndef") ) {
450 s += 5;
451 }
452
453 return s;
454 }
455
456 /*
457 =for apidoc new_version
458
459 Returns a new version object based on the passed in SV:
460
461 SV *sv = new_version(SV *ver);
462
463 Does not alter the passed in ver SV. See "upg_version" if you
464 want to upgrade the SV.
465
466 =cut
467 */
468
469 SV *
470 #ifdef VUTIL_REPLACE_CORE
Perl_new_version2(pTHX_ SV * ver)471 Perl_new_version2(pTHX_ SV *ver)
472 #else
473 Perl_new_version(pTHX_ SV *ver)
474 #endif
475 {
476 SV * const rv = newSV(0);
477 PERL_ARGS_ASSERT_NEW_VERSION;
478 if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
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 */
494 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
495 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
496
497 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
498 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
499 {
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 }
505 }
506 {
507 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
508 if(svp)
509 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
510 }
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 {
515 SV * const sv = *av_fetch(sav, key, FALSE);
516 const I32 rev = SvIV(sv);
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;
528 const char * const version = (const char*)mg->mg_ptr;
529 char *raw, *under;
530 static const char underscore[] = "_";
531 sv_setpvn(rv,version,len);
532 raw = SvPV_nolen(rv);
533 under = ninstr(raw, raw+len, underscore, underscore + 1);
534 if (under) {
535 Move(under + 1, under, raw + len - under - 1, char);
536 SvCUR_set(rv, SvCUR(rv) - 1);
537 *SvEND(rv) = '\0';
538 }
539 /* this is for consistency with the pure Perl class */
540 if ( isDIGIT(*version) )
541 sv_insert(rv, 0, 0, "v", 1);
542 }
543 else {
544 #endif
545 SvSetSV_nosteal(rv, ver); /* make a duplicate */
546 #ifdef SvVOK
547 }
548 }
549 #endif
550 sv_2mortal(rv); /* in case upg_version croaks before it returns */
551 return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
552 }
553
554 /*
555 =for apidoc upg_version
556
557 In-place upgrade of the supplied SV to a version object.
558
559 SV *sv = upg_version(SV *sv, bool qv);
560
561 Returns a pointer to the upgraded SV. Set the boolean qv if you want
562 to force this SV to be interpreted as an "extended" version.
563
564 =cut
565 */
566
567 SV *
568 #ifdef VUTIL_REPLACE_CORE
Perl_upg_version2(pTHX_ SV * ver,bool qv)569 Perl_upg_version2(pTHX_ SV *ver, bool qv)
570 #else
571 Perl_upg_version(pTHX_ SV *ver, bool qv)
572 #endif
573 {
574 const char *version, *s;
575 #ifdef SvVOK
576 const MAGIC *mg;
577 #endif
578
579 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
580 ENTER;
581 #endif
582 PERL_ARGS_ASSERT_UPG_VERSION;
583
584 if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
585 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
586 /* out of bounds [unsigned] integer */
587 STRLEN len;
588 char tbuf[64];
589 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
590 version = savepvn(tbuf, len);
591 SAVEFREEPV(version);
592 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
593 "Integer overflow in version %d",VERSION_MAX);
594 }
595 else if ( SvUOK(ver) || SvIOK(ver))
596 #if PERL_VERSION_LT(5,17,2)
597 VER_IV:
598 #endif
599 {
600 version = savesvpv(ver);
601 SAVEFREEPV(version);
602 }
603 else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
604 #if PERL_VERSION_LT(5,17,2)
605 VER_NV:
606 #endif
607 {
608 STRLEN len;
609
610 /* may get too much accuracy */
611 char tbuf[64];
612 #ifdef __vax__
613 SV *sv = SvNVX(ver) > 10e37 ? newSV(64) : 0;
614 #else
615 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
616 #endif
617 char *buf;
618
619 #if PERL_VERSION_GE(5,19,0)
620 if (SvPOK(ver)) {
621 /* dualvar? */
622 goto VER_PV;
623 }
624 #endif
625 #ifdef USE_LOCALE_NUMERIC
626
627 {
628 /* This may or may not be called from code that has switched
629 * locales without letting perl know, therefore we have to find it
630 * from first principals. See [perl #121930]. */
631
632 /* In windows, or not threaded, or not thread-safe, if it isn't C,
633 * set it to C. */
634
635 # ifndef USE_POSIX_2008_LOCALE
636
637 const char * locale_name_on_entry;
638
639 LC_NUMERIC_LOCK(0); /* Start critical section */
640
641 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
642 if ( strNE(locale_name_on_entry, "C")
643 && strNE(locale_name_on_entry, "POSIX"))
644 {
645 /* the setlocale() call might free or overwrite the name */
646 locale_name_on_entry = savepv(locale_name_on_entry);
647 setlocale(LC_NUMERIC, "C");
648 }
649 else { /* This value indicates to the restore code that we didn't
650 change the locale */
651 locale_name_on_entry = NULL;
652 }
653
654 # else
655
656 const locale_t locale_obj_on_entry = uselocale((locale_t) 0);
657 const char * locale_name_on_entry = NULL;
658 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
659
660 if (locale_obj_on_entry == LC_GLOBAL_LOCALE) {
661
662 /* in the global locale, we can call system setlocale and if it
663 * isn't C, set it to C. */
664 LC_NUMERIC_LOCK(0);
665
666 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
667 if ( strNE(locale_name_on_entry, "C")
668 && strNE(locale_name_on_entry, "POSIX"))
669 {
670 /* the setlocale() call might free or overwrite the name */
671 locale_name_on_entry = savepv(locale_name_on_entry);
672 setlocale(LC_NUMERIC, "C");
673 }
674 else { /* This value indicates to the restore code that we
675 didn't change the locale */
676 locale_name_on_entry = NULL;
677 }
678 }
679 else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
680 /* Here, the locale appears to have been changed to use the
681 * program's underlying locale. Just use our mechanisms to
682 * switch back to C. It might be possible for this pointer to
683 * actually refer to something else if it got released and
684 * reused somehow. But it doesn't matter, our mechanisms will
685 * work even so */
686 STORE_LC_NUMERIC_SET_STANDARD();
687 }
688 else if (locale_obj_on_entry != PL_C_locale_obj) {
689 /* The C object should be unchanged during a program's
690 * execution, so it should be safe to assume it means what it
691 * says, so if we are in it, no locale change is required.
692 * Otherwise, simply use the thread-safe operation. */
693 uselocale(PL_C_locale_obj);
694 }
695
696 # endif
697
698 /* Prevent recursed calls from trying to change back */
699 LOCK_LC_NUMERIC_STANDARD();
700
701 #endif
702
703 if (sv) {
704 Perl_sv_setpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver));
705 len = SvCUR(sv);
706 buf = SvPVX(sv);
707 }
708 else {
709 len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver));
710 buf = tbuf;
711 }
712
713 #ifdef USE_LOCALE_NUMERIC
714
715 UNLOCK_LC_NUMERIC_STANDARD();
716
717 # ifndef USE_POSIX_2008_LOCALE
718
719 if (locale_name_on_entry) {
720 setlocale(LC_NUMERIC, locale_name_on_entry);
721 Safefree(locale_name_on_entry);
722 }
723
724 LC_NUMERIC_UNLOCK; /* End critical section */
725
726 # else
727
728 if (locale_name_on_entry) {
729 setlocale(LC_NUMERIC, locale_name_on_entry);
730 Safefree(locale_name_on_entry);
731 LC_NUMERIC_UNLOCK;
732 }
733 else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
734 RESTORE_LC_NUMERIC();
735 }
736 else if (locale_obj_on_entry != PL_C_locale_obj) {
737 uselocale(locale_obj_on_entry);
738 }
739
740 # endif
741
742 }
743
744 #endif /* USE_LOCALE_NUMERIC */
745
746 while (buf[len-1] == '0' && len > 0) len--;
747 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
748 version = savepvn(buf, len);
749 SAVEFREEPV(version);
750 SvREFCNT_dec(sv);
751 }
752 #ifdef SvVOK
753 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
754 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
755 SAVEFREEPV(version);
756 qv = TRUE;
757 }
758 #endif
759 else if ( SvPOK(ver))/* must be a string or something like a string */
760 VER_PV:
761 {
762 STRLEN len;
763 version = savepvn(SvPV(ver,len), SvCUR(ver));
764 SAVEFREEPV(version);
765 #ifndef SvVOK
766 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
767 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
768 /* may be a v-string */
769 char *testv = (char *)version;
770 STRLEN tlen = len;
771 for (tlen=0; tlen < len; tlen++, testv++) {
772 /* if one of the characters is non-text assume v-string */
773 if (testv[0] < ' ') {
774 SV * const nsv = sv_newmortal();
775 const char *nver;
776 const char *pos;
777 int saw_decimal = 0;
778 sv_setpvf(nsv,"v%vd",ver);
779 pos = nver = savepv(SvPV_nolen(nsv));
780 SAVEFREEPV(pos);
781
782 /* scan the resulting formatted string */
783 pos++; /* skip the leading 'v' */
784 while ( *pos == '.' || isDIGIT(*pos) ) {
785 if ( *pos == '.' )
786 saw_decimal++ ;
787 pos++;
788 }
789
790 /* is definitely a v-string */
791 if ( saw_decimal >= 2 ) {
792 version = nver;
793 }
794 break;
795 }
796 }
797 }
798 #endif
799 }
800 #if PERL_VERSION_LT(5,17,2)
801 else if (SvIOKp(ver)) {
802 goto VER_IV;
803 }
804 else if (SvNOKp(ver)) {
805 goto VER_NV;
806 }
807 else if (SvPOKp(ver)) {
808 goto VER_PV;
809 }
810 #endif
811 else
812 {
813 /* no idea what this is */
814 Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
815 }
816
817 s = SCAN_VERSION(version, ver, qv);
818 if ( *s != '\0' )
819 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
820 "Version string '%s' contains invalid data; "
821 "ignoring: '%s'", version, s);
822
823 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
824 LEAVE;
825 #endif
826
827 return ver;
828 }
829
830 /*
831 =for apidoc vverify
832
833 Validates that the SV contains valid internal structure for a version object.
834 It may be passed either the version object (RV) or the hash itself (HV). If
835 the structure is valid, it returns the HV. If the structure is invalid,
836 it returns NULL.
837
838 SV *hv = vverify(sv);
839
840 Note that it only confirms the bare minimum structure (so as not to get
841 confused by derived classes which may contain additional hash entries):
842
843 =over 4
844
845 =item * The SV is an HV or a reference to an HV
846
847 =item * The hash contains a "version" key
848
849 =item * The "version" key has a reference to an AV as its value
850
851 =back
852
853 =cut
854 */
855
856 SV *
857 #ifdef VUTIL_REPLACE_CORE
Perl_vverify2(pTHX_ SV * vs)858 Perl_vverify2(pTHX_ SV *vs)
859 #else
860 Perl_vverify(pTHX_ SV *vs)
861 #endif
862 {
863 SV *sv;
864 SV **svp;
865
866 PERL_ARGS_ASSERT_VVERIFY;
867
868 if ( SvROK(vs) )
869 vs = SvRV(vs);
870
871 /* see if the appropriate elements exist */
872 if ( SvTYPE(vs) == SVt_PVHV
873 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
874 && (sv = SvRV(*svp))
875 && SvTYPE(sv) == SVt_PVAV )
876 return vs;
877 else
878 return NULL;
879 }
880
881 /*
882 =for apidoc vnumify
883
884 Accepts a version object and returns the normalized floating
885 point representation. Call like:
886
887 sv = vnumify(rv);
888
889 NOTE: you can pass either the object directly or the SV
890 contained within the RV.
891
892 The SV returned has a refcount of 1.
893
894 =cut
895 */
896
897 SV *
898 #ifdef VUTIL_REPLACE_CORE
Perl_vnumify2(pTHX_ SV * vs)899 Perl_vnumify2(pTHX_ SV *vs)
900 #else
901 Perl_vnumify(pTHX_ SV *vs)
902 #endif
903 {
904 SSize_t i, len;
905 I32 digit;
906 bool alpha = FALSE;
907 SV *sv;
908 AV *av;
909
910 PERL_ARGS_ASSERT_VNUMIFY;
911
912 /* extract the HV from the object */
913 vs = VVERIFY(vs);
914 if ( ! vs )
915 Perl_croak(aTHX_ "Invalid version object");
916
917 /* see if various flags exist */
918 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
919 alpha = TRUE;
920
921 if (alpha) {
922 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
923 "alpha->numify() is lossy");
924 }
925
926 /* attempt to retrieve the version array */
927 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
928 return newSVpvs("0");
929 }
930
931 len = av_len(av);
932 if ( len == -1 )
933 {
934 return newSVpvs("0");
935 }
936
937 {
938 SV * tsv = *av_fetch(av, 0, 0);
939 digit = SvIV(tsv);
940 }
941 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
942 for ( i = 1 ; i <= len ; i++ )
943 {
944 SV * tsv = *av_fetch(av, i, 0);
945 digit = SvIV(tsv);
946 Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
947 }
948
949 if ( len == 0 ) {
950 sv_catpvs(sv, "000");
951 }
952 return sv;
953 }
954
955 /*
956 =for apidoc vnormal
957
958 Accepts a version object and returns the normalized string
959 representation. Call like:
960
961 sv = vnormal(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_vnormal2(pTHX_ SV * vs)973 Perl_vnormal2(pTHX_ SV *vs)
974 #else
975 Perl_vnormal(pTHX_ SV *vs)
976 #endif
977 {
978 I32 i, len, digit;
979 SV *sv;
980 AV *av;
981
982 PERL_ARGS_ASSERT_VNORMAL;
983
984 /* extract the HV from the object */
985 vs = VVERIFY(vs);
986 if ( ! vs )
987 Perl_croak(aTHX_ "Invalid version object");
988
989 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
990
991 len = av_len(av);
992 if ( len == -1 )
993 {
994 return newSVpvs("");
995 }
996 {
997 SV * tsv = *av_fetch(av, 0, 0);
998 digit = SvIV(tsv);
999 }
1000 sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit);
1001 for ( i = 1 ; i <= len ; i++ ) {
1002 SV * tsv = *av_fetch(av, i, 0);
1003 digit = SvIV(tsv);
1004 Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit);
1005 }
1006
1007 if ( len <= 2 ) { /* short version, must be at least three */
1008 for ( len = 2 - len; len != 0; len-- )
1009 sv_catpvs(sv,".0");
1010 }
1011 return sv;
1012 }
1013
1014 /*
1015 =for apidoc vstringify
1016
1017 In order to maintain maximum compatibility with earlier versions
1018 of Perl, this function will return either the floating point
1019 notation or the multiple dotted notation, depending on whether
1020 the original version contained 1 or more dots, respectively.
1021
1022 The SV returned has a refcount of 1.
1023
1024 =cut
1025 */
1026
1027 SV *
1028 #ifdef VUTIL_REPLACE_CORE
Perl_vstringify2(pTHX_ SV * vs)1029 Perl_vstringify2(pTHX_ SV *vs)
1030 #else
1031 Perl_vstringify(pTHX_ SV *vs)
1032 #endif
1033 {
1034 SV ** svp;
1035 PERL_ARGS_ASSERT_VSTRINGIFY;
1036
1037 /* extract the HV from the object */
1038 vs = VVERIFY(vs);
1039 if ( ! vs )
1040 Perl_croak(aTHX_ "Invalid version object");
1041
1042 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
1043 if (svp) {
1044 SV *pv;
1045 pv = *svp;
1046 if ( SvPOK(pv)
1047 #if PERL_VERSION_LT(5,17,2)
1048 || SvPOKp(pv)
1049 #endif
1050 )
1051 return newSVsv(pv);
1052 else
1053 return &PL_sv_undef;
1054 }
1055 else {
1056 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
1057 return VNORMAL(vs);
1058 else
1059 return VNUMIFY(vs);
1060 }
1061 }
1062
1063 /*
1064 =for apidoc vcmp
1065
1066 Version object aware cmp. Both operands must already have been
1067 converted into version objects.
1068
1069 =cut
1070 */
1071
1072 int
1073 #ifdef VUTIL_REPLACE_CORE
Perl_vcmp2(pTHX_ SV * lhv,SV * rhv)1074 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1075 #else
1076 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
1077 #endif
1078 {
1079 SSize_t i,l,m,r;
1080 I32 retval;
1081 I32 left = 0;
1082 I32 right = 0;
1083 AV *lav, *rav;
1084
1085 PERL_ARGS_ASSERT_VCMP;
1086
1087 /* extract the HVs from the objects */
1088 lhv = VVERIFY(lhv);
1089 rhv = VVERIFY(rhv);
1090 if ( ! ( lhv && rhv ) )
1091 Perl_croak(aTHX_ "Invalid version object");
1092
1093 /* get the left hand term */
1094 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
1095
1096 /* and the right hand term */
1097 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
1098
1099 l = av_len(lav);
1100 r = av_len(rav);
1101 m = l < r ? l : r;
1102 retval = 0;
1103 i = 0;
1104 while ( i <= m && retval == 0 )
1105 {
1106 SV * const lsv = *av_fetch(lav,i,0);
1107 SV * rsv;
1108 left = SvIV(lsv);
1109 rsv = *av_fetch(rav,i,0);
1110 right = SvIV(rsv);
1111 if ( left < right )
1112 retval = -1;
1113 if ( left > right )
1114 retval = +1;
1115 i++;
1116 }
1117
1118 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1119 {
1120 if ( l < r )
1121 {
1122 while ( i <= r && retval == 0 )
1123 {
1124 SV * const rsv = *av_fetch(rav,i,0);
1125 if ( SvIV(rsv) != 0 )
1126 retval = -1; /* not a match after all */
1127 i++;
1128 }
1129 }
1130 else
1131 {
1132 while ( i <= l && retval == 0 )
1133 {
1134 SV * const lsv = *av_fetch(lav,i,0);
1135 if ( SvIV(lsv) != 0 )
1136 retval = +1; /* not a match after all */
1137 i++;
1138 }
1139 }
1140 }
1141 return retval;
1142 }
1143
1144 /* ex: set ro: */
1145