diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
index eee1b029b687700b6cfd1c4aa87872eac5f86a8d..598a3d677dad4589c337487ee45404fd0d59a2e6 100644
--- a/Cabal/Cabal.cabal
+++ b/Cabal/Cabal.cabal
@@ -681,3 +681,26 @@ test-suite hackage-tests
ghc-options: -Wall -rtsopts -threaded
default-extensions: CPP
default-language: Haskell2010
+
+test-suite rpmvercmp
+ type: exitcode-stdio-1.0
+ main-is: RPMVerCmp.hs
+
+ hs-source-dirs: tests
+ build-depends:
+ base,
+ Cabal,
+ bytestring
+
+ build-depends:
+ tasty >= 1.1.0.3 && < 1.2,
+ tasty-hunit,
+ tasty-quickcheck,
+ QuickCheck
+
+ c-sources: tests/cbits/rpmvercmp.c
+ cc-options: -Wall
+ pkgconfig-depends: glib-2.0
+
+ ghc-options: -Wall
+ default-language: Haskell2010
diff --git a/Cabal/tests/RPMVerCmp.hs b/Cabal/tests/RPMVerCmp.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8be48056d71d8acdf75d60a332bc51a709c83079
--- /dev/null
+++ b/Cabal/tests/RPMVerCmp.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Data.Monoid ((<>))
+import Data.Word (Word8)
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt (..))
+import System.IO.Unsafe (unsafePerformIO)
+
+import Test.QuickCheck (Arbitrary (..), (===))
+import Test.Tasty (defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+import Test.Tasty.QuickCheck (testProperty)
+
+import Distribution.Pretty (prettyShow)
+import Distribution.Types.Version
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+
+-------------------------------------------------------------------------------
+-- C reference implementation
+-------------------------------------------------------------------------------
+
+foreign import ccall unsafe "rpmvercmp" c_rmpvercmp
+ :: CString -> CString -> CInt
+
+rpmvercmpRef :: BS.ByteString -> BS.ByteString -> Ordering
+rpmvercmpRef a b = unsafePerformIO $
+ BS.useAsCString a $ \a' ->
+ BS.useAsCString b $ \b' ->
+ return $ fromInt $ c_rmpvercmp a' b'
+ where
+ fromInt = flip compare 0
+
+-------------------------------------------------------------------------------
+-- Pure implementation
+-------------------------------------------------------------------------------
+
+rpmvercmpPure :: BS.ByteString -> BS.ByteString -> Ordering
+rpmvercmpPure a b = go0 (BS.unpack a) (BS.unpack b)
+ where
+ go0 :: [Word8] -> [Word8] -> Ordering
+ go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys)
+
+ go1 :: [Word8] -> [Word8] -> Ordering
+ go1 [] [] = EQ
+ go1 [] _ = LT
+ go1 _ [] = GT
+ go1 xs@(x:_) ys
+ | isDigit8 x =
+ let (xs1, xs2) = span isDigit8 xs
+ (ys1, ys2) = span isDigit8 ys
+ -- numeric segments are always newer than alpha segments
+ in if null ys1
+ then GT
+ else compareInt xs1 ys1 <> go0 xs2 ys2
+
+ -- isAlpha
+ | otherwise =
+ let (xs1, xs2) = span isAlpha8 xs
+ (ys1, ys2) = span isAlpha8 ys
+ in if null ys1
+ then LT
+ else compareStr xs1 ys1 <> go0 xs2 ys2
+
+-- compare as numbers
+compareInt :: [Word8] -> [Word8] -> Ordering
+compareInt xs ys =
+ -- whichever number has more digits wins
+ compare (length xs') (length ys') <>
+ -- equal length: use per character compare, "strcmp"
+ compare xs' ys'
+ where
+ -- drop leading zeros
+ xs' = dropWhile (== 0x30) xs
+ ys' = dropWhile (== 0x30) ys
+
+-- strcmp
+compareStr :: [Word8] -> [Word8] -> Ordering
+compareStr = compare
+
+dropNonAlnum8 :: [Word8] -> [Word8]
+dropNonAlnum8 = dropWhile (\w -> not (isDigit8 w || isAlpha8 w))
+
+isDigit8 :: Word8 -> Bool
+isDigit8 w = 0x30 <= w && w <= 0x39
+
+isAlpha8 :: Word8 -> Bool
+isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A)
+
+-------------------------------------------------------------------------------
+-- Tests
+-------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain $ testGroup "rpmvercmp"
+ [ testGroup "examples"
+ [ example "openssl" "1.1.0g" "1.1.0i" LT
+ , example "openssl" "1.0.2h" "1.1.0" LT
+
+ , example "simple" "1.2.3" "1.2.4" LT
+ , example "word" "apple" "banana" LT
+
+ , example "corner case" "r" "" GT
+ , example "corner case" "0" "1" LT
+ , example "corner case" "1" "0.0" GT
+ ]
+ , testGroup "Properties"
+ [ testProperty "ref reflexive" $ \a ->
+ rpmvercmpRef (BS.pack a) (BS.pack a) === EQ
+ , testProperty "pure reflexive" $ \a ->
+ rpmvercmpPure (BS.pack a) (BS.pack a) === EQ
+ , testProperty "ref agrees with Version" $ \a b ->
+ compare a b === rpmvercmpRef (v2bs a) (v2bs b)
+ , testProperty "pure agrees with Version" $ \a b ->
+ compare a b === rpmvercmpPure (v2bs a) (v2bs b)
+ ]
+ , testGroup "Random inputs"
+ [ testProperty "random" $ \xs ys ->
+ let xs' = BS.pack $ unnull $ filter (/= 0) xs
+ ys' = BS.pack $ unnull $ filter (/= 0) ys
+
+ -- ref doesn't really work with empty inputs reliably.
+ unnull [] = [1]
+ unnull zs = zs
+ in rpmvercmpRef xs' ys' === rpmvercmpPure xs' ys'
+ ]
+ ]
+ where
+ example n a b c = testCase (n ++ " " ++ BS8.unpack a ++ " <=> " ++ BS8.unpack b) $ do
+ let ref = rpmvercmpRef a b
+ let pur = rpmvercmpPure a b
+ assertEqual "ref" c ref
+ assertEqual "pure" c pur
+
+-------------------------------------------------------------------------------
+-- Version arbitrary
+-------------------------------------------------------------------------------
+
+newtype V = V Version
+ deriving (Show, Eq, Ord)
+
+unV :: V -> Version
+unV (V x) = x
+
+instance Arbitrary V where
+ arbitrary = V . mkVersion_ <$> arbitrary
+
+ shrink = map V . filter (/= version0) . map mkVersion_ . shrink . versionNumbers . unV
+
+mkVersion_ :: [Int] -> Version
+mkVersion_ [] = version0
+mkVersion_ xs = mkVersion (map abs xs)
+
+v2bs :: V -> BS.ByteString
+v2bs (V x) = BS8.pack (prettyShow x)
diff --git a/Cabal/tests/cbits/rpmvercmp.c b/Cabal/tests/cbits/rpmvercmp.c
new file mode 100644
index 0000000000000000000000000000000000000000..09efd7c98e72144aa0ee2d3c4970f209ce22c220
--- /dev/null
+++ b/Cabal/tests/cbits/rpmvercmp.c
@@ -0,0 +1,130 @@
+/*
+ * This code is taken from the RPM package manager.
+ *
+ * RPM is Copyright (c) 1998 by Red Hat Software, Inc.,
+ * and may be distributed under the terms of the GPL and LGPL.
+ * See http://rpm.org/gitweb?p=rpm.git;a=blob_plain;f=COPYING;hb=HEAD
+ *
+ * The code should follow upstream as closely as possible.
+ * See http://rpm.org/gitweb?p=rpm.git;a=blob_plain;f=lib/rpmvercmp.c;hb=HEAD
+ *
+ * Currently the only difference as a policy is that upstream uses C99
+ * features and pkg-config does not require a C99 compiler yet.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <glib.h>
+#include <string.h>
+#include <ctype.h>
+#include <stdio.h>
+
+/* macros to help code look more like upstream */
+#define rstreq(a, b) (strcmp(a, b) == 0)
+#define risalnum(c) isalnum((guchar)(c))
+#define risdigit(c) isdigit((guchar)(c))
+#define risalpha(c) isalpha((guchar)(c))
+
+/* compare alpha and numeric segments of two versions */
+/* return 1: a is newer than b */
+/* 0: a and b are the same version */
+/* -1: b is newer than a */
+int rpmvercmp(const char * a, const char * b)
+{
+ char oldch1, oldch2;
+ char * str1, * str2;
+ char * one, * two;
+ int rc;
+ int isnum;
+
+ /* easy comparison to see if versions are identical */
+ if (rstreq(a, b)) return 0;
+
+ str1 = g_alloca(strlen(a) + 1);
+ str2 = g_alloca(strlen(b) + 1);
+
+ strcpy(str1, a);
+ strcpy(str2, b);
+
+ one = str1;
+ two = str2;
+
+ /* loop through each version segment of str1 and str2 and compare them */
+ while (*one && *two) {
+ while (*one && !risalnum(*one)) one++;
+ while (*two && !risalnum(*two)) two++;
+
+ /* If we ran to the end of either, we are finished with the loop */
+ if (!(*one && *two)) break;
+
+ str1 = one;
+ str2 = two;
+
+ /* grab first completely alpha or completely numeric segment */
+ /* leave one and two pointing to the start of the alpha or numeric */
+ /* segment and walk str1 and str2 to end of segment */
+ if (risdigit(*str1)) {
+ while (*str1 && risdigit(*str1)) str1++;
+ while (*str2 && risdigit(*str2)) str2++;
+ isnum = 1;
+ } else {
+ while (*str1 && risalpha(*str1)) str1++;
+ while (*str2 && risalpha(*str2)) str2++;
+ isnum = 0;
+ }
+
+ /* save character at the end of the alpha or numeric segment */
+ /* so that they can be restored after the comparison */
+ oldch1 = *str1;
+ *str1 = '\0';
+ oldch2 = *str2;
+ *str2 = '\0';
+
+ /* this cannot happen, as we previously tested to make sure that */
+ /* the first string has a non-null segment */
+ if (one == str1) return -1; /* arbitrary */
+
+ /* take care of the case where the two version segments are */
+ /* different types: one numeric, the other alpha (i.e. empty) */
+ /* numeric segments are always newer than alpha segments */
+ /* XXX See patch #60884 (and details) from bugzilla #50977. */
+ if (two == str2) return (isnum ? 1 : -1);
+
+ if (isnum) {
+ /* this used to be done by converting the digit segments */
+ /* to ints using atoi() - it's changed because long */
+ /* digit segments can overflow an int - this should fix that. */
+
+ /* throw away any leading zeros - it's a number, right? */
+ while (*one == '0') one++;
+ while (*two == '0') two++;
+
+ /* whichever number has more digits wins */
+ if (strlen(one) > strlen(two)) return 1;
+ if (strlen(two) > strlen(one)) return -1;
+ }
+
+ /* strcmp will return which one is greater - even if the two */
+ /* segments are alpha or if they are numeric. don't return */
+ /* if they are equal because there might be more segments to */
+ /* compare */
+ rc = strcmp(one, two);
+ if (rc) return (rc < 1 ? -1 : 1);
+
+ /* restore character that was replaced by null above */
+ *str1 = oldch1;
+ one = str1;
+ *str2 = oldch2;
+ two = str2;
+ }
+
+ /* this catches the case where all numeric and alpha segments have */
+ /* compared identically but the segment sepparating characters were */
+ /* different */
+ if ((!*one) && (!*two)) return 0;
+
+ /* whichever version still has characters left over wins */
+ if (!*one) return -1; else return 1;
+}