Dpkg::Version: new implementation and new object interface

The old implementation is still around in this commit so that
it's easy to checkout this commit and add supplementary test cases
in scripts/t/100_Dpkg_Version.t to verify that both implementations
have the same result. Some new test cases have been added during the
implementation.

The new object interface overrides all the comparison operators
so that you can directly compare two Dpkg::Version objects. The
object can also be used within strings and it will generate the
same version string than the one given at creation time.

scripts/Dpkg/Version.pm

@@ -1,6 +1,7 @@
 # Copyright © Colin Watson <cjwatson@debian.org>
 # Copyright © Ian Jackson <iwj@debian.org>
 # Copyright © 2007 Don Armstrong <don@donarmstrong.com>.
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
 
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -25,25 +26,335 @@ use Dpkg::ErrorHandling;
 use Dpkg::Gettext;
 
 use base qw(Exporter);
+our @EXPORT = qw(version_compare version_compare_op
+                 version_normalize_cmp_op version_compare_string
+                 version_compare_part version_split_digits version_check
+                 CMP_OP_LT CMP_OP_LE CMP_OP_EQ CMP_OP_GE CMP_OP_GT);
 our @EXPORT_OK = qw(vercmp compare_versions check_version parseversion);
 
+use constant {
+    CMP_OP_LT => '<<',
+    CMP_OP_LE => '<=',
+    CMP_OP_EQ => '=',
+    CMP_OP_GE => '>=',
+    CMP_OP_GT => '>>',
+};
+
+use overload
+    '<=>' => \&comparison,
+    'cmp' => \&comparison,
+    '""'  => \&as_string,
+    'bool' => sub { return 1 };
+
 =head1 NAME
 
-Dpkg::Version - pure-Perl dpkg-style version comparison
+Dpkg::Version - handling and comparing dpkg-style version numbers
 
 =head1 DESCRIPTION
 
 The Dpkg::Version module provides pure-Perl routines to compare
-dpkg-style version numbers, as used in Debian packages. If you have the
-libapt-pkg Perl bindings available (Debian package libapt-pkg-perl), they
-may offer better performance.
+dpkg-style version numbers (as used in Debian packages) and also
+an object oriented interface overriding perl operators
+to do the right thing when you compare Dpkg::Version object between
+them.
+
+=head1 OBJECT INTERFACE
+
+=over 4
+
+=item my $v = Dpkg::Version->new($version)
+
+Create a new Dpkg::Version object corresponding to the version indicated in
+the string (scalar) $version. Returns undef if the string doesn't contain
+a valid version (see version_check for details).
+
+=cut
+
+sub new {
+    my ($this, $ver) = @_;
+    my $class = ref($this) || $this;
+    $ver = "$ver" if ref($ver); # Try to stringify objects
+    return undef unless version_check($ver);
+
+    my $self = {};
+    if ($ver =~ /^(\d*):(.+)$/) {
+	$self->{'epoch'} = $1;
+	$ver = $2;
+    } else {
+	$self->{'epoch'} = 0;
+	$self->{'no_epoch'} = 1;
+    }
+    if ($ver =~ /(.+)-(.*)$/) {
+	$self->{'version'} = $1;
+	$self->{'revision'} = $2;
+    } else {
+	$self->{'version'} = $ver;
+	$self->{'revision'} = 0;
+	$self->{'no_revision'} = 1;
+    }
+
+    return bless $self, $class;
+}
+
+=item $v->epoch(), $v->version(), $v->revision()
+
+Returns the corresponding part of the full version string.
+
+=cut
+
+sub epoch {
+    my $self = shift;
+    return $self->{'epoch'};
+}
+
+sub version {
+    my $self = shift;
+    return $self->{'version'};
+}
+
+sub revision {
+    my $self = shift;
+    return $self->{'revision'};
+}
+
+=item $v1 <=> $v2, $v1 < $v2, $v1 <= $v2, $v1 > $v2, $v1 >= $v2
+
+Numerical comparison of various versions numbers. One of the two operands
+needs to be a Dpkg::Version, the other one can be anything provided that
+its string representation is a version number.
+
+=cut
+
+sub comparison {
+    my ($a, $b, $inverted) = @_;
+    if (not ref($b) or not $b->isa("Dpkg::Version")) {
+        $b = Dpkg::Version->new($b);
+    }
+    ($a, $b) = ($b, $a) if $inverted;
+    my $r = $a->epoch() <=> $b->epoch();
+    return $r if $r;
+    $r = version_compare_part($a->version(), $b->version());
+    return $r if $r;
+    return version_compare_part($a->revision(), $b->revision());
+}
+
+=item "$v"
+=item $v->as_string()
+
+Returns the string representation of the version number.
+
+=cut
+sub as_string {
+    my ($self) = @_;
+    my $str = "";
+    $str .= $self->{epoch} . ":" unless $self->{no_epoch};
+    $str .= $self->{version};
+    $str .= "-" . $self->{revision} unless $self->{no_revision};
+    return $str;
+}
+
+=back
+
+=head1 FUNCTIONS
+
+All the functions are exported by default.
+
+=over 4
+
+=item version_compare($a, $b)
+
+Returns -1 is $a is smaller than $b, 0 if they are equal and 1 if $a
+is bigger than $b.
+
+If $a or $b are not valid version numbers, it dies with an error.
+
+=cut
+
+sub version_compare($$) {
+    my ($a, $b) = @_;
+    my $va = Dpkg::Version->new($a) || error(_g("%s is not a valid version"), "$a");
+    my $vb = Dpkg::Version->new($b) || error(_g("%s is not a valid version"), "$b");
+    return $va <=> $vb;
+}
+
+=item version_compare_op($a, $op, $b)
+
+Returns the result (0 or 1) of the given comparison operation. This
+function is implemented on top of version_compare().
 
-=head1 METHODS
+Allowed values for $op are the exported constants CMP_OP_GT, CMP_OP_GE,
+CMP_OP_EQ, CMP_OP_LE, CMP_OP_LT. Use version_normalize_cmp_op() if you
+have an input string containing the operator.
 
-=over 8
+=cut
+
+sub version_compare_op($$$) {
+    my ($a, $op, $b) = @_;
+    my $res = version_compare($a, $b);
+
+    if ($op eq CMP_OP_GT) {
+	return $res > 0;
+    } elsif ($op eq CMP_OP_GE) {
+	return $res >= 0;
+    } elsif ($op eq CMP_OP_EQ) {
+	return $res == 0;
+    } elsif ($op eq CMP_OP_LE) {
+	return $res <= 0;
+    } elsif ($op eq CMP_OP_LT) {
+	return $res < 0;
+    } else {
+	internerr("unsupported operator for version_compare_op(): '$op'");
+    }
+}
+
+=item my $cmp_op = version_normalize_cmp_op($op)
+
+Returns the normalized constant of the comparison operator $op (a value
+among CMP_OP_GT, CMP_OP_GE, CMP_OP_EQ, CMP_OP_LE and CMP_OP_LT). Supported
+operators names in input are: "gt", "ge", "eq", "le", "lt", ">>", ">=",
+"=", "<=", "<<". ">" and "<" are also supported but should not be used as
+they are obsolete aliases of ">=" and "<=".
+
+=cut
+
+sub version_normalize_cmp_op($) {
+    my $op = shift;
+
+    warning("operator %s is deprecated: use %s or %s",
+            $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<');
+
+    if ($op eq '>>' or $op eq 'gt') {
+	return CMP_OP_GT;
+    } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') {
+	return CMP_OP_GE;
+    } elsif ($op eq '=' or $op eq 'eq') {
+	return CMP_OP_EQ;
+    } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') {
+	return CMP_OP_LE;
+    } elsif ($op eq '<<' or $op eq 'lt') {
+	return CMP_OP_LT;
+    } else {
+	internerr("bad comparison operator '$op'");
+    }
+}
+
+=item version_compare_string($a, $b)
+
+String comparison function used for comparing non-numerical parts of version
+numbers. Returns -1 is $a is smaller than $b, 0 if they are equal and 1 if $a
+is bigger than $b.
+
+The "~" character always sort lower than anything else. Digits sort lower
+than non-digits. Among remaining characters alphabetic characters (A-Za-z)
+sort lower than the other ones. Within each range, the ASCII decimal value
+of the character is used to sort between characters.
 
 =cut
 
+sub version_compare_string($$) {
+    sub order(_) {
+        my ($x) = @_;
+	if ($x eq '~') {
+	    return -1;
+	} elsif ($x =~ /^\d$/) {
+	    return $x * 1 + 1;
+	} elsif ($x =~ /^[A-Za-z]$/) {
+	    return ord($x);
+	} else {
+	    return ord($x) + 256;
+	}
+    }
+    my @a = map(order, split(//, shift));
+    my @b = map(order, split(//, shift));
+    while (1) {
+        my ($a, $b) = (shift @a, shift @b);
+        return 0 if not defined($a) and not defined($b);
+        $a ||= 0; # Default order for "no character"
+        $b ||= 0;
+        return 1 if $a > $b;
+        return -1 if $a < $b;
+    }
+}
+
+=item version_compare_part($a, $b)
+
+Compare two corresponding sub-parts of a version number (either upstream
+version or debian revision).
+
+Each parameter is split by version_split_digits() and resulting items
+are compared together.in digits and non-digits items that are compared
+together. As soon as a difference happens, it returns -1 if $a is smaller
+than $b, 0 if they are equal and 1 if $a is bigger than $b.
+
+=cut
+
+sub version_compare_part($$) {
+    my @a = version_split_digits(shift);
+    my @b = version_split_digits(shift);
+    while (1) {
+        my ($a, $b) = (shift @a, shift @b);
+        return 0 if not defined($a) and not defined($b);
+        $a ||= 0; # Default value for lack of version
+        $b ||= 0;
+        if ($a =~ /^\d+$/ and $b =~ /^\d+$/) {
+            # Numerical comparison
+            my $cmp = $a <=> $b;
+            return $cmp if $cmp;
+        } else {
+            # String comparison
+            my $cmp = version_compare_string($a, $b);
+            return $cmp if $cmp;
+        }
+    }
+}
+
+=item my @items = version_split_digits($version)
+
+Splits a string in items that are each entirely composed either
+of digits or of non-digits. For instance for "1.024~beta1+svn234" it would
+return ("1", ".", "024", "~beta", "1", "+svn", "234").
+
+=cut
+
+sub version_split_digits($) {
+    return split(/(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $_[0]);
+}
+
+=item my ($ok, $msg) = version_check($version)
+=item my $ok = version_check($version)
+
+Checks the validity of $version as a version number. Returns 1 in $ok
+if the version is valid, 0 otherwise. In the latter case, $msg
+contains a description of the problem with the $version scalar.
+
+=cut
+
+sub version_check($) {
+    my $version = shift;
+    $version = "$version" if ref($version);
+
+    if (not defined($version) or not length($version)) {
+        my $msg = _g("version number cannot be empty");
+        return (0, $msg) if wantarray;
+        return 0;
+    }
+    if ($version =~ m/([^-+:.0-9a-zA-Z~])/o) {
+        my $msg = sprintf(_g("version number contains illegal character `%s'"), $1);
+        return (0, $msg) if wantarray;
+        return 0;
+    }
+    if ($version =~ /:/ and $version !~ /^\d*:/) {
+        $version =~ /^([^:]*):/;
+        my $msg = sprintf(_g("epoch part of the version number " .
+                             "is not a number: '%s'"), $1);
+        return (0, $msg) if wantarray;
+        return 0;
+    }
+    return (1, "") if wantarray;
+    return 1;
+}
+
+
 sub parseversion ($)
 {
     my $ver = shift;
@@ -57,6 +368,7 @@ sub parseversion ($)
     else
     {
 	$verhash{epoch} = 0;
+	$verhash{no_epoch} = 1;
     }
     if ($ver =~ /(.+)-(.*)$/)
     {
@@ -67,6 +379,7 @@ sub parseversion ($)
     {
 	$verhash{version} = $ver;
 	$verhash{revision} = 0;
+	$verhash{no_revision} = 1;
     }
     return %verhash;
 }
@@ -80,7 +393,7 @@ sub parseversion ($)
 sub verrevcmp($$)
 {
 
-     sub order{
+     sub _order{
 	  my ($x) = @_;
 	  ##define order(x) ((x) == '~' ? -1 \
 	  #           : cisdigit((x)) ? 0 \
@@ -117,7 +430,7 @@ sub verrevcmp($$)
 	  my $first_diff = 0;
 	  while ((defined $vc and $vc !~ /^\d$/) or
 		 (defined $rc and $rc !~ /^\d$/)) {
-	       my $vo = order($vc); my $ro = order($rc);
+	       my $vo = _order($vc); my $ro = _order($rc);
 	       # Unlike dpkg's verrevcmp, we only return 1 or -1 here.
 	       return (($vo - $ro > 0) ? 1 : -1) if $vo != $ro;
 	       $vc = shift @val; $rc = shift @ref;
@@ -217,9 +530,9 @@ sub check_version ($;$) {
 
 =head1 AUTHOR
 
-Don Armstrong <don@donarmstrong.com> and Colin Watson
-E<lt>cjwatson@debian.orgE<gt>, based on the implementation in
-C<dpkg/lib/vercmp.c> by Ian Jackson and others.
+Don Armstrong <don@donarmstrong.com>, Colin Watson
+<cjwatson@debian.org> and Raphaël Hertzog <hertzog@debian.org>, based on
+the implementation in C<dpkg/lib/vercmp.c> by Ian Jackson and others.
 
 =cut
 

scripts/t/100_Dpkg_Version.t

@@ -15,13 +15,27 @@ my @ops = ("<", "<<", "lt",
 	   ">=", "ge",
 	   ">", ">>", "gt");
 
-plan tests => scalar(@tests) * (2 * scalar(@ops) + 1) + 1;
+plan tests => scalar(@tests) * (3 * scalar(@ops) + 2) + 1;
 
 sub dpkg_vercmp {
      my ($a, $cmp, $b) = @_;
      return system('dpkg', '--compare-versions', $a, $cmp, $b) == 0;
 }
 
+sub obj_vercmp {
+     my ($a, $cmp, $b) = @_;
+     return $a < $b  if $cmp eq "<<";
+     return $a lt $b if $cmp eq "lt";
+     return $a <= $b if $cmp eq "<=" or $cmp eq "<";
+     return $a le $b if $cmp eq "le";
+     return $a == $b if $cmp eq "=";
+     return $a eq $b if $cmp eq "eq";
+     return $a >= $b if $cmp eq ">=" or $cmp eq ">";
+     return $a ge $b if $cmp eq "ge";
+     return $a > $b  if $cmp eq ">>";
+     return $a gt $b if $cmp eq "gt";
+}
+
 use_ok('Dpkg::Version', qw(vercmp compare_versions));
 
 my $truth = {
@@ -50,13 +64,19 @@ my $truth = {
 
 foreach my $case (@tests) {
     my ($a, $b, $res) = split " ", $case;
+    my $va = Dpkg::Version->new($a);
+    my $vb = Dpkg::Version->new($b);
+
     is(vercmp($a, $b), $res, "$a cmp $b => $res");
+    is($va <=> $vb, $res, "Dpkg::Version($a) <=> Dpkg::Version($b) => $res");
     foreach my $op (@ops) {
 	if ($truth->{$res}{$op}) {
 	    ok(compare_versions($a, $op, $b), "$a $op $b => true");
+	    ok(obj_vercmp($va, $op, $vb), "Dpkg::Version($a) $op Dpkg::Version($b) => true");
 	    ok(dpkg_vercmp($a, $op, $b), "dpkg --compare-versions $a $op $b => true");
 	} else {
 	    ok(!compare_versions($a, $op, $b), "$a $op $b => false");
+	    ok(!obj_vercmp($va, $op, $vb), "Dpkg::Version($a) $op Dpkg::Version($b) => false");
 	    ok(!dpkg_vercmp($a, $op, $b), "dpkg --compare-versions $a $op $b => false");
 	}
     }
@@ -68,16 +88,19 @@ __DATA__
 2.2-1 2.2~rc-4 1
 1.0000-1 1.0-1 0
 1 0:1 0
+0 0:0-0 0
 2:2.5 1:7.5 1
 1:foo foo 1
 0:foo foo 0
 foo foo 0
 foo- foo 0
+foo- foo-0 0
 foo fo 1
 foo- foo+ -1
 foo~1 foo -1
 foo~foo+Bar foo~foo+bar -1
 foo~~ foo~ -1
+1~ 1 -1
 12345+that-really-is-some-ver-0 12345+that-really-is-some-ver-10 -1
 foo-0 foo-01 -1
 foo.bar foobar 1
@@ -102,3 +125,4 @@ foo2.1 foo2.10 -1
 2:2.3.2-2+lenny2 2:2.3.2-2 1
 1:3.8.1-1 3.8.GA-1 1
 1.0.1+gpl-1 1.0.1-2 1
+1a 1000a -1