1 /* This file is part of the "version" CPAN distribution. Please avoid
2 editing it in the perl core. */
5 # define PERL_NO_GET_CONTEXT
9 # define NEED_my_snprintf
10 # define NEED_newRV_noinc
11 # define NEED_vnewSVpvf
12 # define NEED_newSVpvn_flags_GLOBAL
18 #define VERSION_MAX 0x7FFFFFFF
23 =for apidoc prescan_version
25 Validate that a given string can be parsed as a version object, but doesn't
26 actually perform the parsing. Can use either strict or lax validation rules.
27 Can optionally set a number of hint variables to save the parsing code
28 some time when tokenizing.
33 #ifdef VUTIL_REPLACE_CORE
34 Perl_prescan_version2(pTHX_ const char *s, bool strict,
36 Perl_prescan_version(pTHX_ const char *s, bool strict,
39 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
40 bool qv = (sqv ? *sqv : FALSE);
46 PERL_ARGS_ASSERT_PRESCAN_VERSION;
48 if (qv && isDIGIT(*d))
49 goto dotted_decimal_version;
51 if (*d == 'v') { /* explicit v-string */
56 else { /* degenerate v-string */
58 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
61 dotted_decimal_version:
62 if (strict && d[0] == '0' && isDIGIT(d[1])) {
63 /* no leading zeros allowed */
64 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
67 while (isDIGIT(*d)) /* integer part */
73 d++; /* decimal point */
79 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
82 goto version_prescan_finish;
89 while (isDIGIT(*d)) { /* just keep reading */
93 /* maximum 3 digits between decimal */
94 if (strict && j > 3) {
95 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
100 BADVERSION(s,errstr,"Invalid version format (no underscores)");
103 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
108 else if (*d == '.') {
110 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
115 else if (!isDIGIT(*d)) {
121 if (strict && i < 2) {
122 /* requires v1.2.3 */
123 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
126 } /* end if dotted-decimal */
128 { /* decimal versions */
129 int j = 0; /* may need this later */
130 /* special strict case for leading '.' or '0' */
133 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
135 if (*d == '0' && isDIGIT(d[1])) {
136 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
140 /* and we never support negative versions */
142 BADVERSION(s,errstr,"Invalid version format (negative version number)");
145 /* consume all of the integer part */
149 /* look for a fractional part */
151 /* we found it, so consume it */
155 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
158 BADVERSION(s,errstr,"Invalid version format (version required)");
160 /* found just an integer */
161 goto version_prescan_finish;
164 /* didn't find either integer or period */
165 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
167 else if (*d == '_') {
168 /* underscore can't come after integer part */
170 BADVERSION(s,errstr,"Invalid version format (no underscores)");
172 else if (isDIGIT(d[1])) {
173 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
176 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
180 /* anything else after integer part is just invalid data */
181 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
184 /* scan the fractional part after the decimal point*/
186 if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
187 /* strict or lax-but-not-the-end */
188 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
191 while (isDIGIT(*d)) {
193 if (*d == '.' && isDIGIT(d[-1])) {
195 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
198 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
200 d = (char *)s; /* start all over again */
202 goto dotted_decimal_version;
206 BADVERSION(s,errstr,"Invalid version format (no underscores)");
209 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
211 if ( ! isDIGIT(d[1]) ) {
212 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
221 version_prescan_finish:
225 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
226 /* trailing non-numeric data */
227 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
235 *ssaw_decimal = saw_decimal;
242 =for apidoc scan_version
244 Returns a pointer to the next character after the parsed
245 version string, as well as upgrading the passed in SV to
248 Function must be called with an already existing SV like
251 s = scan_version(s, SV *sv, bool qv);
253 Performs some preprocessing to the string to ensure that
254 it has the correct characteristics of a version. Flags the
255 object if it contains an underscore (which denotes this
256 is an alpha version). The boolean qv denotes that the version
257 should be interpreted as if it had multiple decimals, even if
264 #ifdef VUTIL_REPLACE_CORE
265 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
267 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
270 const char *start = s;
273 const char *errstr = NULL;
281 PERL_ARGS_ASSERT_SCAN_VERSION;
283 while (isSPACE(*s)) /* leading whitespace is OK */
286 last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
288 /* "undef" is a special case and not an error */
289 if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
290 Perl_croak(aTHX_ "%s", errstr);
299 /* Now that we are through the prescan, start creating the object */
301 hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
302 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
304 #ifndef NODEFAULT_SHAREKEYS
305 HvSHAREKEYS_on(hv); /* key-sharing on by default */
309 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
311 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
312 if ( !qv && width < 3 )
313 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
315 while (isDIGIT(*pos))
317 if (!isALPHA(*pos)) {
323 /* this is atoi() that delimits on underscores */
324 const char *end = pos;
328 /* the following if() will only be true after the decimal
329 * point of a version originally created with a bare
330 * floating point number, i.e. not quoted in any way
332 if ( !qv && s > start && saw_decimal == 1 ) {
336 rev += (*s - '0') * mult;
338 if ( (PERL_ABS(orev) > PERL_ABS(rev))
339 || (PERL_ABS(rev) > VERSION_MAX )) {
340 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
341 "Integer overflow in version %d",VERSION_MAX);
354 rev += (*end - '0') * mult;
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");
368 /* Append revision */
369 av_push(av, newSViv(rev));
374 else if ( *pos == '.' )
376 else if ( *pos == '_' && isDIGIT(pos[1]) )
378 else if ( *pos == ',' && isDIGIT(pos[1]) )
380 else if ( isDIGIT(*pos) )
387 while ( isDIGIT(*pos) )
392 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
400 if ( qv ) { /* quoted versions always get at least three terms*/
401 SSize_t len = AvFILLp(av);
402 /* This for loop appears to trigger a compiler bug on OS X, as it
403 loops infinitely. Yes, len is negative. No, it makes no sense.
404 Compiler in question is:
405 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
406 for ( len = 2 - len; len > 0; len-- )
407 av_push(MUTABLE_AV(sv), newSViv(0));
411 av_push(av, newSViv(0));
414 /* need to save off the current version string for later */
416 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
417 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
418 (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
420 else if ( s > start ) {
421 SV * orig = newSVpvn(start,s-start);
422 if ( qv && saw_decimal == 1 && *start != 'v' ) {
423 /* need to insert a v to be consistent */
424 sv_insert(orig, 0, 0, "v", 1);
426 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
429 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
430 av_push(av, newSViv(0));
433 /* And finally, store the AV in the hash */
434 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
436 /* fix RT#19517 - special case 'undef' as string */
437 if ( *s == 'u' && strEQ(s+1,"ndef") ) {
445 =for apidoc new_version
447 Returns a new version object based on the passed in SV:
449 SV *sv = new_version(SV *ver);
451 Does not alter the passed in ver SV. See "upg_version" if you
452 want to upgrade the SV.
458 #ifdef VUTIL_REPLACE_CORE
459 Perl_new_version2(pTHX_ SV *ver)
461 Perl_new_version(pTHX_ SV *ver)
465 SV * const rv = newSV(0);
466 PERL_ARGS_ASSERT_NEW_VERSION;
467 if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
470 AV * const av = newAV();
472 /* This will get reblessed later if a derived class*/
473 SV * const hv = newSVrv(rv, "version");
474 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
475 #ifndef NODEFAULT_SHAREKEYS
476 HvSHAREKEYS_on(hv); /* key-sharing on by default */
482 /* Begin copying all of the elements */
483 if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
484 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
486 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
487 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
489 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
491 const I32 width = SvIV(*svp);
492 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
496 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
498 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
500 sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
501 /* This will get reblessed later if a derived class*/
502 for ( key = 0; key <= av_len(sav); key++ )
504 SV * const sv = *av_fetch(sav, key, FALSE);
505 const I32 rev = SvIV(sv);
506 av_push(av, newSViv(rev));
509 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
514 const MAGIC* const mg = SvVSTRING_mg(ver);
515 if ( mg ) { /* already a v-string */
516 const STRLEN len = mg->mg_len;
517 const char * const version = (const char*)mg->mg_ptr;
518 sv_setpvn(rv,version,len);
519 /* this is for consistency with the pure Perl class */
520 if ( isDIGIT(*version) )
521 sv_insert(rv, 0, 0, "v", 1);
525 SvSetSV_nosteal(rv, ver); /* make a duplicate */
530 sv_2mortal(rv); /* in case upg_version croaks before it returns */
531 return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
535 =for apidoc upg_version
537 In-place upgrade of the supplied SV to a version object.
539 SV *sv = upg_version(SV *sv, bool qv);
541 Returns a pointer to the upgraded SV. Set the boolean qv if you want
542 to force this SV to be interpreted as an "extended" version.
548 #ifdef VUTIL_REPLACE_CORE
549 Perl_upg_version2(pTHX_ SV *ver, bool qv)
551 Perl_upg_version(pTHX_ SV *ver, bool qv)
554 const char *version, *s;
559 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
562 PERL_ARGS_ASSERT_UPG_VERSION;
564 if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
565 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
566 /* out of bounds [unsigned] integer */
569 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
570 version = savepvn(tbuf, len);
572 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
573 "Integer overflow in version %d",VERSION_MAX);
575 else if ( SvUOK(ver) || SvIOK(ver))
576 #if PERL_VERSION_LT(5,17,2)
580 version = savesvpv(ver);
583 else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
584 #if PERL_VERSION_LT(5,17,2)
590 /* may get too much accuracy */
592 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
594 STORE_NUMERIC_LOCAL_SET_STANDARD();
595 LOCK_NUMERIC_STANDARD();
597 Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
602 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
605 UNLOCK_NUMERIC_STANDARD();
606 RESTORE_NUMERIC_LOCAL();
607 while (buf[len-1] == '0' && len > 0) len--;
608 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
609 version = savepvn(buf, len);
614 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
615 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
620 else if ( SvPOK(ver))/* must be a string or something like a string */
621 #if PERL_VERSION_LT(5,17,2)
626 version = savepvn(SvPV(ver,len), SvCUR(ver));
629 # if PERL_VERSION > 5
630 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
631 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
632 /* may be a v-string */
633 char *testv = (char *)version;
635 for (tlen=0; tlen < len; tlen++, testv++) {
636 /* if one of the characters is non-text assume v-string */
637 if (testv[0] < ' ') {
638 SV * const nsv = sv_newmortal();
642 sv_setpvf(nsv,"v%vd",ver);
643 pos = nver = savepv(SvPV_nolen(nsv));
646 /* scan the resulting formatted string */
647 pos++; /* skip the leading 'v' */
648 while ( *pos == '.' || isDIGIT(*pos) ) {
654 /* is definitely a v-string */
655 if ( saw_decimal >= 2 ) {
665 #if PERL_VERSION_LT(5,17,2)
666 else if (SvIOKp(ver)) {
669 else if (SvNOKp(ver)) {
672 else if (SvPOKp(ver)) {
678 /* no idea what this is */
679 Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
682 s = SCAN_VERSION(version, ver, qv);
684 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
685 "Version string '%s' contains invalid data; "
686 "ignoring: '%s'", version, s);
688 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
698 Validates that the SV contains valid internal structure for a version object.
699 It may be passed either the version object (RV) or the hash itself (HV). If
700 the structure is valid, it returns the HV. If the structure is invalid,
703 SV *hv = vverify(sv);
705 Note that it only confirms the bare minimum structure (so as not to get
706 confused by derived classes which may contain additional hash entries):
710 =item * The SV is an HV or a reference to an HV
712 =item * The hash contains a "version" key
714 =item * The "version" key has a reference to an AV as its value
722 #ifdef VUTIL_REPLACE_CORE
723 Perl_vverify2(pTHX_ SV *vs)
725 Perl_vverify(pTHX_ SV *vs)
731 PERL_ARGS_ASSERT_VVERIFY;
736 /* see if the appropriate elements exist */
737 if ( SvTYPE(vs) == SVt_PVHV
738 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
740 && SvTYPE(sv) == SVt_PVAV )
749 Accepts a version object and returns the normalized floating
750 point representation. Call like:
754 NOTE: you can pass either the object directly or the SV
755 contained within the RV.
757 The SV returned has a refcount of 1.
763 #ifdef VUTIL_REPLACE_CORE
764 Perl_vnumify2(pTHX_ SV *vs)
766 Perl_vnumify(pTHX_ SV *vs)
776 PERL_ARGS_ASSERT_VNUMIFY;
778 /* extract the HV from the object */
781 Perl_croak(aTHX_ "Invalid version object");
783 /* see if various flags exist */
784 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
787 SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
795 /* attempt to retrieve the version array */
796 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
797 return newSVpvs("0");
803 return newSVpvs("0");
807 SV * tsv = *av_fetch(av, 0, 0);
810 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
811 for ( i = 1 ; i < len ; i++ )
813 SV * tsv = *av_fetch(av, i, 0);
816 const int denom = (width == 2 ? 10 : 100);
817 const div_t term = div((int)PERL_ABS(digit),denom);
818 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
821 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
827 SV * tsv = *av_fetch(av, len, 0);
829 if ( alpha && width == 3 ) /* alpha version */
831 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
835 sv_catpvs(sv, "000");
843 Accepts a version object and returns the normalized string
844 representation. Call like:
848 NOTE: you can pass either the object directly or the SV
849 contained within the RV.
851 The SV returned has a refcount of 1.
857 #ifdef VUTIL_REPLACE_CORE
858 Perl_vnormal2(pTHX_ SV *vs)
860 Perl_vnormal(pTHX_ SV *vs)
868 PERL_ARGS_ASSERT_VNORMAL;
870 /* extract the HV from the object */
873 Perl_croak(aTHX_ "Invalid version object");
875 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
877 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
885 SV * tsv = *av_fetch(av, 0, 0);
888 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
889 for ( i = 1 ; i < len ; i++ ) {
890 SV * tsv = *av_fetch(av, i, 0);
892 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
897 /* handle last digit specially */
898 SV * tsv = *av_fetch(av, len, 0);
901 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
903 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
906 if ( len <= 2 ) { /* short version, must be at least three */
907 for ( len = 2 - len; len != 0; len-- )
914 =for apidoc vstringify
916 In order to maintain maximum compatibility with earlier versions
917 of Perl, this function will return either the floating point
918 notation or the multiple dotted notation, depending on whether
919 the original version contained 1 or more dots, respectively.
921 The SV returned has a refcount of 1.
927 #ifdef VUTIL_REPLACE_CORE
928 Perl_vstringify2(pTHX_ SV *vs)
930 Perl_vstringify(pTHX_ SV *vs)
934 PERL_ARGS_ASSERT_VSTRINGIFY;
936 /* extract the HV from the object */
939 Perl_croak(aTHX_ "Invalid version object");
941 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
951 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
961 Version object aware cmp. Both operands must already have been
962 converted into version objects.
968 #ifdef VUTIL_REPLACE_CORE
969 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
971 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
982 PERL_ARGS_ASSERT_VCMP;
984 /* extract the HVs from the objects */
987 if ( ! ( lhv && rhv ) )
988 Perl_croak(aTHX_ "Invalid version object");
990 /* get the left hand term */
991 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
992 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
995 /* and the right hand term */
996 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
997 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
1005 while ( i <= m && retval == 0 )
1007 SV * const lsv = *av_fetch(lav,i,0);
1010 rsv = *av_fetch(rav,i,0);
1019 /* tiebreaker for alpha with identical terms */
1020 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
1022 if ( lalpha && !ralpha )
1026 else if ( ralpha && !lalpha)
1032 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1036 while ( i <= r && retval == 0 )
1038 SV * const rsv = *av_fetch(rav,i,0);
1039 if ( SvIV(rsv) != 0 )
1040 retval = -1; /* not a match after all */
1046 while ( i <= l && retval == 0 )
1048 SV * const lsv = *av_fetch(lav,i,0);
1049 if ( SvIV(lsv) != 0 )
1050 retval = +1; /* not a match after all */