diff options
| -rw-r--r-- | scripts/Dpkg/Version.pm | 335 | ||||
| -rw-r--r-- | scripts/t/100_Dpkg_Version.t | 26 |
2 files changed, 349 insertions, 12 deletions
diff --git a/scripts/Dpkg/Version.pm b/scripts/Dpkg/Version.pm index 0a83fdda7..382cb3763 100644 --- a/scripts/Dpkg/Version.pm +++ b/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 diff --git a/scripts/t/100_Dpkg_Version.t b/scripts/t/100_Dpkg_Version.t index 5d3beed6e..b36db1ca8 100644 --- a/scripts/t/100_Dpkg_Version.t +++ b/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 |