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