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
13Validate that a given string can be parsed as a version object, but doesn't
14actually perform the parsing.  Can use either strict or lax validation rules.
15Can optionally set a number of hint variables to save the parsing code
16some time when tokenizing.
17
18=cut
19*/
20const char *
21#ifdef VUTIL_REPLACE_CORE
22Perl_prescan_version2(pTHX_ const char *s, bool strict,
23#else
24Perl_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
50dotted_decimal_version:
51	if (strict && d[0] == '0' && isDIGIT(d[1])) {
52	    /* no leading zeros allowed */
53	    BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
54	}
55
56	while (isDIGIT(*d)) 	/* integer part */
57	    d++;
58
59	if (*d == '.')
60	{
61	    saw_decimal++;
62	    d++; 		/* decimal point */
63	}
64	else
65	{
66	    if (strict) {
67		/* require v1.2.3 */
68		BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
69	    }
70	    else {
71		goto version_prescan_finish;
72	    }
73	}
74
75	{
76	    int i = 0;
77	    int j = 0;
78	    while (isDIGIT(*d)) {	/* just keep reading */
79		i++;
80		while (isDIGIT(*d)) {
81		    d++; j++;
82		    /* maximum 3 digits between decimal */
83		    if (strict && j > 3) {
84			BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
85		    }
86		}
87		if (*d == '_') {
88		    if (strict) {
89			BADVERSION(s,errstr,"Invalid version format (no underscores)");
90		    }
91		    if ( alpha ) {
92			BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
93		    }
94		    d++;
95		    alpha = TRUE;
96		}
97		else if (*d == '.') {
98		    if (alpha) {
99			BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
100		    }
101		    saw_decimal++;
102		    d++;
103		}
104		else if (!isDIGIT(*d)) {
105		    break;
106		}
107		j = 0;
108	    }
109
110	    if (strict && i < 2) {
111		/* requires v1.2.3 */
112		BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
113	    }
114	}
115    } 					/* end if dotted-decimal */
116    else
117    {					/* decimal versions */
118	int j = 0;			/* may need this later */
119	/* special strict case for leading '.' or '0' */
120	if (strict) {
121	    if (*d == '.') {
122		BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
123	    }
124	    if (*d == '0' && isDIGIT(d[1])) {
125		BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
126	    }
127	}
128
129	/* and we never support negative versions */
130	if ( *d == '-') {
131	    BADVERSION(s,errstr,"Invalid version format (negative version number)");
132	}
133
134	/* consume all of the integer part */
135	while (isDIGIT(*d))
136	    d++;
137
138	/* look for a fractional part */
139	if (*d == '.') {
140	    /* we found it, so consume it */
141	    saw_decimal++;
142	    d++;
143	}
144	else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
145	    if ( d == s ) {
146		/* found nothing */
147		BADVERSION(s,errstr,"Invalid version format (version required)");
148	    }
149	    /* found just an integer */
150	    goto version_prescan_finish;
151	}
152	else if ( d == s ) {
153	    /* didn't find either integer or period */
154	    BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
155	}
156	else if (*d == '_') {
157	    /* underscore can't come after integer part */
158	    if (strict) {
159		BADVERSION(s,errstr,"Invalid version format (no underscores)");
160	    }
161	    else if (isDIGIT(d[1])) {
162		BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
163	    }
164	    else {
165		BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
166	    }
167	}
168	else {
169	    /* anything else after integer part is just invalid data */
170	    BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
171	}
172
173	/* scan the fractional part after the decimal point*/
174
175	if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
176		/* strict or lax-but-not-the-end */
177		BADVERSION(s,errstr,"Invalid version format (fractional part required)");
178	}
179
180	while (isDIGIT(*d)) {
181	    d++; j++;
182	    if (*d == '.' && isDIGIT(d[-1])) {
183		if (alpha) {
184		    BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
185		}
186		if (strict) {
187		    BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
188		}
189		d = (char *)s; 		/* start all over again */
190		qv = TRUE;
191		goto dotted_decimal_version;
192	    }
193	    if (*d == '_') {
194		if (strict) {
195		    BADVERSION(s,errstr,"Invalid version format (no underscores)");
196		}
197		if ( alpha ) {
198		    BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
199		}
200		if ( ! isDIGIT(d[1]) ) {
201		    BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
202		}
203		width = j;
204		d++;
205		alpha = TRUE;
206	    }
207	}
208    }
209
210version_prescan_finish:
211    while (isSPACE(*d))
212	d++;
213
214    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
215	/* trailing non-numeric data */
216	BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
217    }
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
238Returns a pointer to the next character after the parsed
239version string, as well as upgrading the passed in SV to
240an RV.
241
242Function must be called with an already existing SV like
243
244    sv = newSV(0);
245    s = scan_version(s, SV *sv, bool qv);
246
247Performs some preprocessing to the string to ensure that
248it has the correct characteristics of a version.  Flags the
249object if it contains an underscore (which denotes this
250is an alpha version).  The boolean qv denotes that the version
251should be interpreted as if it had multiple decimals, even if
252it doesn't.
253
254=cut
255*/
256
257const char *
258#ifdef VUTIL_REPLACE_CORE
259Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
260#else
261Perl_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
459Returns a new version object based on the passed in SV:
460
461    SV *sv = new_version(SV *ver);
462
463Does not alter the passed in ver SV.  See "upg_version" if you
464want to upgrade the SV.
465
466=cut
467*/
468
469SV *
470#ifdef VUTIL_REPLACE_CORE
471Perl_new_version2(pTHX_ SV *ver)
472#else
473Perl_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
557In-place upgrade of the supplied SV to a version object.
558
559    SV *sv = upg_version(SV *sv, bool qv);
560
561Returns a pointer to the upgraded SV.  Set the boolean qv if you want
562to force this SV to be interpreted as an "extended" version.
563
564=cut
565*/
566
567SV *
568#ifdef VUTIL_REPLACE_CORE
569Perl_upg_version2(pTHX_ SV *ver, bool qv)
570#else
571Perl_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)
597VER_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)
605VER_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 */
760VER_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
833Validates that the SV contains valid internal structure for a version object.
834It may be passed either the version object (RV) or the hash itself (HV).  If
835the structure is valid, it returns the HV.  If the structure is invalid,
836it returns NULL.
837
838    SV *hv = vverify(sv);
839
840Note that it only confirms the bare minimum structure (so as not to get
841confused 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
856SV *
857#ifdef VUTIL_REPLACE_CORE
858Perl_vverify2(pTHX_ SV *vs)
859#else
860Perl_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
884Accepts a version object and returns the normalized floating
885point representation.  Call like:
886
887    sv = vnumify(rv);
888
889NOTE: you can pass either the object directly or the SV
890contained within the RV.
891
892The SV returned has a refcount of 1.
893
894=cut
895*/
896
897SV *
898#ifdef VUTIL_REPLACE_CORE
899Perl_vnumify2(pTHX_ SV *vs)
900#else
901Perl_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
958Accepts a version object and returns the normalized string
959representation.  Call like:
960
961    sv = vnormal(rv);
962
963NOTE: you can pass either the object directly or the SV
964contained within the RV.
965
966The SV returned has a refcount of 1.
967
968=cut
969*/
970
971SV *
972#ifdef VUTIL_REPLACE_CORE
973Perl_vnormal2(pTHX_ SV *vs)
974#else
975Perl_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
1017In order to maintain maximum compatibility with earlier versions
1018of Perl, this function will return either the floating point
1019notation or the multiple dotted notation, depending on whether
1020the original version contained 1 or more dots, respectively.
1021
1022The SV returned has a refcount of 1.
1023
1024=cut
1025*/
1026
1027SV *
1028#ifdef VUTIL_REPLACE_CORE
1029Perl_vstringify2(pTHX_ SV *vs)
1030#else
1031Perl_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
1066Version object aware cmp.  Both operands must already have been
1067converted into version objects.
1068
1069=cut
1070*/
1071
1072int
1073#ifdef VUTIL_REPLACE_CORE
1074Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1075#else
1076Perl_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