1 /* This file is part of the "version" CPAN distribution. Please avoid
2 editing it in the perl core. */
8 #define VERSION_MAX 0x7FFFFFFF
11 =for apidoc_section Versioning
13 =for apidoc prescan_version
15 Validate that a given string can be parsed as a version object, but doesn't
16 actually perform the parsing. Can use either strict or lax validation rules.
17 Can optionally set a number of hint variables to save the parsing code
18 some time when tokenizing.
23 #ifdef VUTIL_REPLACE_CORE
24 Perl_prescan_version2(pTHX_ const char *s, bool strict,
26 Perl_prescan_version(pTHX_ const char *s, bool strict,
29 bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
30 bool qv = (sqv ? *sqv : FALSE);
36 PERL_ARGS_ASSERT_PRESCAN_VERSION;
39 if (qv && isDIGIT(*d))
40 goto dotted_decimal_version;
42 if (*d == 'v') { /* explicit v-string */
47 else { /* degenerate v-string */
49 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
52 dotted_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)");
58 while (isDIGIT(*d)) /* integer part */
64 d++; /* decimal point */
70 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
73 goto version_prescan_finish;
80 while (isDIGIT(*d)) { /* just keep reading */
84 /* maximum 3 digits between decimal */
85 if (strict && j > 3) {
86 BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
91 BADVERSION(s,errstr,"Invalid version format (no underscores)");
94 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
101 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
106 else if (!isDIGIT(*d)) {
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)");
117 } /* end if dotted-decimal */
119 { /* decimal versions */
120 int j = 0; /* may need this later */
121 /* special strict case for leading '.' or '0' */
124 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
126 if (*d == '0' && isDIGIT(d[1])) {
127 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
131 /* and we never support negative versions */
133 BADVERSION(s,errstr,"Invalid version format (negative version number)");
136 /* consume all of the integer part */
140 /* look for a fractional part */
142 /* we found it, so consume it */
146 else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
149 BADVERSION(s,errstr,"Invalid version format (version required)");
151 /* found just an integer */
152 goto version_prescan_finish;
155 /* didn't find either integer or period */
156 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
158 else if (*d == '_') {
159 /* underscore can't come after integer part */
161 BADVERSION(s,errstr,"Invalid version format (no underscores)");
163 else if (isDIGIT(d[1])) {
164 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
167 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
171 /* anything else after integer part is just invalid data */
172 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
175 /* scan the fractional part after the decimal point*/
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)");
182 while (isDIGIT(*d)) {
184 if (*d == '.' && isDIGIT(d[-1])) {
186 BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
189 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
191 d = (char *)s; /* start all over again */
193 goto dotted_decimal_version;
197 BADVERSION(s,errstr,"Invalid version format (no underscores)");
200 BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
202 if ( ! isDIGIT(d[1]) ) {
203 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
212 version_prescan_finish:
216 if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
217 /* trailing non-numeric data */
218 BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
220 if (saw_decimal > 1 && d[-1] == '.') {
221 /* no trailing period allowed */
222 BADVERSION(s,errstr,"Invalid version format (trailing decimal)");
231 *ssaw_decimal = saw_decimal;
238 =for apidoc scan_version
240 Returns a pointer to the next character after the parsed
241 version string, as well as upgrading the passed in SV to
244 Function must be called with an already existing SV like
247 s = scan_version(s, SV *sv, bool qv);
249 Performs some preprocessing to the string to ensure that
250 it has the correct characteristics of a version. Flags the
251 object if it contains an underscore (which denotes this
252 is an alpha version). The boolean qv denotes that the version
253 should be interpreted as if it had multiple decimals, even if
260 #ifdef VUTIL_REPLACE_CORE
261 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
263 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
266 const char *start = s;
269 const char *errstr = NULL;
277 PERL_ARGS_ASSERT_SCAN_VERSION;
279 while (isSPACE(*s)) /* leading whitespace is OK */
282 last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
284 /* "undef" is a special case and not an error */
285 if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
286 Perl_croak(aTHX_ "%s", errstr);
295 /* Now that we are through the prescan, start creating the object */
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 */
300 #ifndef NODEFAULT_SHAREKEYS
301 HvSHAREKEYS_on(hv); /* key-sharing on by default */
305 (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
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));
311 while (isDIGIT(*pos) || *pos == '_')
313 if (!isALPHA(*pos)) {
319 /* this is atoi() that delimits on underscores */
320 const char *end = pos;
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
328 if ( !qv && s > start && saw_decimal == 1 ) {
334 rev += (*s - '0') * mult;
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);
355 if ( (mult == VERSION_MAX)
356 || (i > VERSION_MAX / mult)
357 || (i * mult > VERSION_MAX - rev))
359 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
360 "Integer overflow in version");
368 if (mult > VERSION_MAX / 10)
376 /* Append revision */
377 av_push(av, newSViv(rev));
382 else if ( *pos == '.' ) {
390 else if ( *pos == '_' && isDIGIT(pos[1]) )
392 else if ( *pos == ',' && isDIGIT(pos[1]) )
394 else if ( isDIGIT(*pos) )
401 while ( isDIGIT(*pos) || *pos == '_')
406 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
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));
425 av_push(av, newSViv(0));
428 /* need to save off the current version string for later */
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));
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);
440 (void)hv_stores(MUTABLE_HV(hv), "original", orig);
443 (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
444 av_push(av, newSViv(0));
447 /* And finally, store the AV in the hash */
448 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
450 /* fix RT#19517 - special case 'undef' as string */
451 if ( *s == 'u' && strEQ(s+1,"ndef") ) {
459 =for apidoc new_version
461 Returns a new version object based on the passed in SV:
463 SV *sv = new_version(SV *ver);
465 Does not alter the passed in ver SV. See "upg_version" if you
466 want to upgrade the SV.
472 #ifdef VUTIL_REPLACE_CORE
473 Perl_new_version2(pTHX_ SV *ver)
475 Perl_new_version(pTHX_ SV *ver)
478 SV * const rv = newSV(0);
479 PERL_ARGS_ASSERT_NEW_VERSION;
480 if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
483 AV * const av = newAV();
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 */
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));
499 if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
500 (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
502 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
504 const I32 width = SvIV(*svp);
505 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
509 SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
511 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
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++ )
517 SV * const sv = *av_fetch(sav, key, FALSE);
518 const I32 rev = SvIV(sv);
519 av_push(av, newSViv(rev));
522 (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
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;
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);
537 Move(under + 1, under, raw + len - under - 1, char);
538 SvCUR_set(rv, SvCUR(rv) - 1);
541 /* this is for consistency with the pure Perl class */
542 if ( isDIGIT(*version) )
543 sv_insert(rv, 0, 0, "v", 1);
547 SvSetSV_nosteal(rv, ver); /* make a duplicate */
552 sv_2mortal(rv); /* in case upg_version croaks before it returns */
553 return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
557 =for apidoc upg_version
559 In-place upgrade of the supplied SV to a version object.
561 SV *sv = upg_version(SV *sv, bool qv);
563 Returns a pointer to the upgraded SV. Set the boolean qv if you want
564 to force this SV to be interpreted as an "extended" version.
570 #ifdef VUTIL_REPLACE_CORE
571 Perl_upg_version2(pTHX_ SV *ver, bool qv)
573 Perl_upg_version(pTHX_ SV *ver, bool qv)
581 const char *version, *s;
586 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
589 PERL_ARGS_ASSERT_UPG_VERSION;
591 if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
592 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
593 /* out of bounds [unsigned] integer */
596 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
597 version = savepvn(tbuf, len);
599 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
600 "Integer overflow in version %d",VERSION_MAX);
602 else if ( SvUOK(ver) || SvIOK(ver))
603 #if PERL_VERSION_LT(5,17,2)
607 version = savesvpv(ver);
610 else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
611 #if PERL_VERSION_LT(5,17,2)
617 /* may get too much accuracy */
619 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
622 #if PERL_VERSION_GE(5,19,0)
628 #ifdef USE_LOCALE_NUMERIC
631 /* This may or may not be called from code that has switched
632 * locales without letting perl know, therefore we have to find it
633 * from first principals. See [perl #121930]. */
635 /* In windows, or not threaded, or not thread-safe, if it isn't C,
638 # ifndef USE_POSIX_2008_LOCALE
640 const char * locale_name_on_entry;
642 LC_NUMERIC_LOCK(0); /* Start critical section */
644 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
645 if ( strNE(locale_name_on_entry, "C")
646 && strNE(locale_name_on_entry, "POSIX"))
648 /* the setlocale() call might free or overwrite the name */
649 locale_name_on_entry = savepv(locale_name_on_entry);
650 setlocale(LC_NUMERIC, "C");
652 else { /* This value indicates to the restore code that we didn't
654 locale_name_on_entry = NULL;
659 const locale_t locale_obj_on_entry = uselocale((locale_t) 0);
660 const char * locale_name_on_entry = NULL;
661 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
663 if (locale_obj_on_entry == LC_GLOBAL_LOCALE) {
665 /* in the global locale, we can call system setlocale and if it
666 * isn't C, set it to C. */
669 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
670 if ( strNE(locale_name_on_entry, "C")
671 && strNE(locale_name_on_entry, "POSIX"))
673 /* the setlocale() call might free or overwrite the name */
674 locale_name_on_entry = savepv(locale_name_on_entry);
675 setlocale(LC_NUMERIC, "C");
677 else { /* This value indicates to the restore code that we
678 didn't change the locale */
679 locale_name_on_entry = NULL;
682 else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
683 /* Here, the locale appears to have been changed to use the
684 * program's underlying locale. Just use our mechanisms to
685 * switch back to C. It might be possible for this pointer to
686 * actually refer to something else if it got released and
687 * reused somehow. But it doesn't matter, our mechanisms will
689 STORE_LC_NUMERIC_SET_STANDARD();
691 else if (locale_obj_on_entry != PL_C_locale_obj) {
692 /* The C object should be unchanged during a program's
693 * execution, so it should be safe to assume it means what it
694 * says, so if we are in it, no locale change is required.
695 * Otherwise, simply use the thread-safe operation. */
696 uselocale(PL_C_locale_obj);
701 /* Prevent recursed calls from trying to change back */
702 LOCK_LC_NUMERIC_STANDARD();
707 Perl_sv_catpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver));
712 len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver));
716 #ifdef USE_LOCALE_NUMERIC
718 UNLOCK_LC_NUMERIC_STANDARD();
720 # ifndef USE_POSIX_2008_LOCALE
722 if (locale_name_on_entry) {
723 setlocale(LC_NUMERIC, locale_name_on_entry);
724 Safefree(locale_name_on_entry);
727 LC_NUMERIC_UNLOCK; /* End critical section */
731 if (locale_name_on_entry) {
732 setlocale(LC_NUMERIC, locale_name_on_entry);
733 Safefree(locale_name_on_entry);
736 else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
737 RESTORE_LC_NUMERIC();
739 else if (locale_obj_on_entry != PL_C_locale_obj) {
740 uselocale(locale_obj_on_entry);
747 #endif /* USE_LOCALE_NUMERIC */
749 while (buf[len-1] == '0' && len > 0) len--;
750 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
751 version = savepvn(buf, len);
756 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
757 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
762 else if ( SvPOK(ver))/* must be a string or something like a string */
766 version = savepvn(SvPV(ver,len), SvCUR(ver));
769 # if PERL_VERSION > 5
770 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
771 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
772 /* may be a v-string */
773 char *testv = (char *)version;
775 for (tlen=0; tlen < len; tlen++, testv++) {
776 /* if one of the characters is non-text assume v-string */
777 if (testv[0] < ' ') {
778 SV * const nsv = sv_newmortal();
782 sv_setpvf(nsv,"v%vd",ver);
783 pos = nver = savepv(SvPV_nolen(nsv));
786 /* scan the resulting formatted string */
787 pos++; /* skip the leading 'v' */
788 while ( *pos == '.' || isDIGIT(*pos) ) {
794 /* is definitely a v-string */
795 if ( saw_decimal >= 2 ) {
805 #if PERL_VERSION_LT(5,17,2)
806 else if (SvIOKp(ver)) {
809 else if (SvNOKp(ver)) {
812 else if (SvPOKp(ver)) {
818 /* no idea what this is */
819 Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
822 s = SCAN_VERSION(version, ver, qv);
824 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
825 "Version string '%s' contains invalid data; "
826 "ignoring: '%s'", version, s);
828 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
838 Validates that the SV contains valid internal structure for a version object.
839 It may be passed either the version object (RV) or the hash itself (HV). If
840 the structure is valid, it returns the HV. If the structure is invalid,
843 SV *hv = vverify(sv);
845 Note that it only confirms the bare minimum structure (so as not to get
846 confused by derived classes which may contain additional hash entries):
850 =item * The SV is an HV or a reference to an HV
852 =item * The hash contains a "version" key
854 =item * The "version" key has a reference to an AV as its value
862 #ifdef VUTIL_REPLACE_CORE
863 Perl_vverify2(pTHX_ SV *vs)
865 Perl_vverify(pTHX_ SV *vs)
871 PERL_ARGS_ASSERT_VVERIFY;
876 /* see if the appropriate elements exist */
877 if ( SvTYPE(vs) == SVt_PVHV
878 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
880 && SvTYPE(sv) == SVt_PVAV )
889 Accepts a version object and returns the normalized floating
890 point representation. Call like:
894 NOTE: you can pass either the object directly or the SV
895 contained within the RV.
897 The SV returned has a refcount of 1.
903 #ifdef VUTIL_REPLACE_CORE
904 Perl_vnumify2(pTHX_ SV *vs)
906 Perl_vnumify(pTHX_ SV *vs)
915 PERL_ARGS_ASSERT_VNUMIFY;
917 /* extract the HV from the object */
920 Perl_croak(aTHX_ "Invalid version object");
922 /* see if various flags exist */
923 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
927 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
928 "alpha->numify() is lossy");
931 /* attempt to retrieve the version array */
932 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
933 return newSVpvs("0");
939 return newSVpvs("0");
943 SV * tsv = *av_fetch(av, 0, 0);
946 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
947 for ( i = 1 ; i <= len ; i++ )
949 SV * tsv = *av_fetch(av, i, 0);
951 Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
955 sv_catpvs(sv, "000");
963 Accepts a version object and returns the normalized string
964 representation. Call like:
968 NOTE: you can pass either the object directly or the SV
969 contained within the RV.
971 The SV returned has a refcount of 1.
977 #ifdef VUTIL_REPLACE_CORE
978 Perl_vnormal2(pTHX_ SV *vs)
980 Perl_vnormal(pTHX_ SV *vs)
987 PERL_ARGS_ASSERT_VNORMAL;
989 /* extract the HV from the object */
992 Perl_croak(aTHX_ "Invalid version object");
994 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
1002 SV * tsv = *av_fetch(av, 0, 0);
1005 sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit);
1006 for ( i = 1 ; i <= len ; i++ ) {
1007 SV * tsv = *av_fetch(av, i, 0);
1009 Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit);
1012 if ( len <= 2 ) { /* short version, must be at least three */
1013 for ( len = 2 - len; len != 0; len-- )
1020 =for apidoc vstringify
1022 In order to maintain maximum compatibility with earlier versions
1023 of Perl, this function will return either the floating point
1024 notation or the multiple dotted notation, depending on whether
1025 the original version contained 1 or more dots, respectively.
1027 The SV returned has a refcount of 1.
1033 #ifdef VUTIL_REPLACE_CORE
1034 Perl_vstringify2(pTHX_ SV *vs)
1036 Perl_vstringify(pTHX_ SV *vs)
1040 PERL_ARGS_ASSERT_VSTRINGIFY;
1042 /* extract the HV from the object */
1045 Perl_croak(aTHX_ "Invalid version object");
1047 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
1052 #if PERL_VERSION_LT(5,17,2)
1058 return &PL_sv_undef;
1061 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
1071 Version object aware cmp. Both operands must already have been
1072 converted into version objects.
1078 #ifdef VUTIL_REPLACE_CORE
1079 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1081 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
1090 PERL_ARGS_ASSERT_VCMP;
1092 /* extract the HVs from the objects */
1095 if ( ! ( lhv && rhv ) )
1096 Perl_croak(aTHX_ "Invalid version object");
1098 /* get the left hand term */
1099 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
1101 /* and the right hand term */
1102 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
1109 while ( i <= m && retval == 0 )
1111 SV * const lsv = *av_fetch(lav,i,0);
1114 rsv = *av_fetch(rav,i,0);
1123 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1127 while ( i <= r && retval == 0 )
1129 SV * const rsv = *av_fetch(rav,i,0);
1130 if ( SvIV(rsv) != 0 )
1131 retval = -1; /* not a match after all */
1137 while ( i <= l && retval == 0 )
1139 SV * const lsv = *av_fetch(lav,i,0);
1140 if ( SvIV(lsv) != 0 )
1141 retval = +1; /* not a match after all */