chiark - git - mdw - dpkg/blob - scripts/Dpkg/Version.pm

   1 # Copyright © Colin Watson <cjwatson@debian.org>
   2 # Copyright © Ian Jackson <ijackson@chiark.greenend.org.uk>
   3 # Copyright © 2007 Don Armstrong <don@donarmstrong.com>.
   4 # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  18
  19 package Dpkg::Version;
  20
  21 use strict;
  22 use warnings;
  23
  24 our $VERSION = '1.01';
  25 our @EXPORT = qw(
  26     version_compare
  27     version_compare_relation
  28     version_normalize_relation
  29     version_compare_string
  30     version_compare_part
  31     version_split_digits
  32     version_check
  33     REL_LT
  34     REL_LE
  35     REL_EQ
  36     REL_GE
  37     REL_GT
  38 );
  39
  40 use Exporter qw(import);
  41 use Carp;
  42
  43 use Dpkg::Gettext;
  44 use Dpkg::ErrorHandling;
  45
  46 use constant {
  47     REL_LT => '<<',
  48     REL_LE => '<=',
  49     REL_EQ => '=',
  50     REL_GE => '>=',
  51     REL_GT => '>>',
  52 };
  53
  54 use overload
  55     '<=>' => \&_comparison,
  56     'cmp' => \&_comparison,
  57     '""'  => sub { return $_[0]->as_string(); },
  58     'bool' => sub { return $_[0]->as_string() if $_[0]->is_valid(); },
  59     'fallback' => 1;
  60
  61 =encoding utf8
  62
  63 =head1 NAME
  64
  65 Dpkg::Version - handling and comparing dpkg-style version numbers
  66
  67 =head1 DESCRIPTION
  68
  69 The Dpkg::Version module provides pure-Perl routines to compare
  70 dpkg-style version numbers (as used in Debian packages) and also
  71 an object oriented interface overriding perl operators
  72 to do the right thing when you compare Dpkg::Version object between
  73 them.
  74
  75 =head1 METHODS
  76
  77 =over 4
  78
  79 =item $v = Dpkg::Version->new($version, %opts)
  80
  81 Create a new Dpkg::Version object corresponding to the version indicated in
  82 the string (scalar) $version. By default it will accepts any string
  83 and consider it as a valid version. If you pass the option "check => 1",
  84 it will return undef if the version is invalid (see version_check for
  85 details).
  86
  87 You can always call $v->is_valid() later on to verify that the version is
  88 valid.
  89
  90 =cut
  91
  92 sub new {
  93     my ($this, $ver, %opts) = @_;
  94     my $class = ref($this) || $this;
  95     $ver = "$ver" if ref($ver); # Try to stringify objects
  96
  97     if ($opts{check}) {
  98         return unless version_check($ver);
  99     }
 100
 101     my $self = {};
 102     if ($ver =~ /^([^:]*):(.+)$/) {
 103         $self->{epoch} = $1;
 104         $ver = $2;
 105     } else {
 106         $self->{epoch} = 0;
 107         $self->{no_epoch} = 1;
 108     }
 109     if ($ver =~ /(.*)-(.*)$/) {
 110         $self->{version} = $1;
 111         $self->{revision} = $2;
 112     } else {
 113         $self->{version} = $ver;
 114         $self->{revision} = 0;
 115         $self->{no_revision} = 1;
 116     }
 117
 118     return bless $self, $class;
 119 }
 120
 121 =item boolean evaluation
 122
 123 When the Dpkg::Version object is used in a boolean evaluation (for example
 124 in "if ($v)" or "$v || 'default'") it returns its string representation
 125 if the version stored is valid ($v->is_valid()) and undef otherwise.
 126
 127 =item $v->is_valid()
 128
 129 Returns true if the version is valid, false otherwise.
 130
 131 =cut
 132
 133 sub is_valid {
 134     my $self = shift;
 135     return scalar version_check($self);
 136 }
 137
 138 =item $v->epoch(), $v->version(), $v->revision()
 139
 140 Returns the corresponding part of the full version string.
 141
 142 =cut
 143
 144 sub epoch {
 145     my $self = shift;
 146     return $self->{epoch};
 147 }
 148
 149 sub version {
 150     my $self = shift;
 151     return $self->{version};
 152 }
 153
 154 sub revision {
 155     my $self = shift;
 156     return $self->{revision};
 157 }
 158
 159 =item $v->is_native()
 160
 161 Returns true if the version is native, false if it has a revision.
 162
 163 =cut
 164
 165 sub is_native {
 166     my $self = shift;
 167     return $self->{no_revision};
 168 }
 169
 170 =item $v1 <=> $v2, $v1 < $v2, $v1 <= $v2, $v1 > $v2, $v1 >= $v2
 171
 172 Numerical comparison of various versions numbers. One of the two operands
 173 needs to be a Dpkg::Version, the other one can be anything provided that
 174 its string representation is a version number.
 175
 176 =cut
 177
 178 sub _comparison {
 179     my ($a, $b, $inverted) = @_;
 180     if (not ref($b) or not $b->isa('Dpkg::Version')) {
 181         $b = Dpkg::Version->new($b);
 182     }
 183     ($a, $b) = ($b, $a) if $inverted;
 184     my $r = version_compare_part($a->epoch(), $b->epoch());
 185     return $r if $r;
 186     $r = version_compare_part($a->version(), $b->version());
 187     return $r if $r;
 188     return version_compare_part($a->revision(), $b->revision());
 189 }
 190
 191 =item "$v", $v->as_string(), $v->as_string(%options)
 192
 193 Accepts an optional option hash reference, affecting the string conversion.
 194
 195 Options:
 196
 197 =over 8
 198
 199 =item omit_epoch (defaults to 0)
 200
 201 Omit the epoch, if present, in the output string.
 202
 203 =item omit_revision (defaults to 0)
 204
 205 Omit the revision, if present, in the output string.
 206
 207 =back
 208
 209 Returns the string representation of the version number.
 210
 211 =cut
 212
 213 sub as_string {
 214     my ($self, %opts) = @_;
 215     my $no_epoch = $opts{omit_epoch} || $self->{no_epoch};
 216     my $no_revision = $opts{omit_revision} || $self->{no_revision};
 217
 218     my $str = '';
 219     $str .= $self->{epoch} . ':' unless $no_epoch;
 220     $str .= $self->{version};
 221     $str .= '-' . $self->{revision} unless $no_revision;
 222     return $str;
 223 }
 224
 225 =back
 226
 227 =head1 FUNCTIONS
 228
 229 All the functions are exported by default.
 230
 231 =over 4
 232
 233 =item version_compare($a, $b)
 234
 235 Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a
 236 is later than $b.
 237
 238 If $a or $b are not valid version numbers, it dies with an error.
 239
 240 =cut
 241
 242 sub version_compare($$) {
 243     my ($a, $b) = @_;
 244     my $va = Dpkg::Version->new($a, check => 1);
 245     defined($va) || error(g_('%s is not a valid version'), "$a");
 246     my $vb = Dpkg::Version->new($b, check => 1);
 247     defined($vb) || error(g_('%s is not a valid version'), "$b");
 248     return $va <=> $vb;
 249 }
 250
 251 =item version_compare_relation($a, $rel, $b)
 252
 253 Returns the result (0 or 1) of the given comparison operation. This
 254 function is implemented on top of version_compare().
 255
 256 Allowed values for $rel are the exported constants REL_GT, REL_GE,
 257 REL_EQ, REL_LE, REL_LT. Use version_normalize_relation() if you
 258 have an input string containing the operator.
 259
 260 =cut
 261
 262 sub version_compare_relation($$$) {
 263     my ($a, $op, $b) = @_;
 264     my $res = version_compare($a, $b);
 265
 266     if ($op eq REL_GT) {
 267         return $res > 0;
 268     } elsif ($op eq REL_GE) {
 269         return $res >= 0;
 270     } elsif ($op eq REL_EQ) {
 271         return $res == 0;
 272     } elsif ($op eq REL_LE) {
 273         return $res <= 0;
 274     } elsif ($op eq REL_LT) {
 275         return $res < 0;
 276     } else {
 277         croak "unsupported relation for version_compare_relation(): '$op'";
 278     }
 279 }
 280
 281 =item $rel = version_normalize_relation($rel_string)
 282
 283 Returns the normalized constant of the relation $rel (a value
 284 among REL_GT, REL_GE, REL_EQ, REL_LE and REL_LT). Supported
 285 relations names in input are: "gt", "ge", "eq", "le", "lt", ">>", ">=",
 286 "=", "<=", "<<". ">" and "<" are also supported but should not be used as
 287 they are obsolete aliases of ">=" and "<=".
 288
 289 =cut
 290
 291 sub version_normalize_relation($) {
 292     my $op = shift;
 293
 294     warning('relation %s is deprecated: use %s or %s',
 295             $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<');
 296
 297     if ($op eq '>>' or $op eq 'gt') {
 298         return REL_GT;
 299     } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') {
 300         return REL_GE;
 301     } elsif ($op eq '=' or $op eq 'eq') {
 302         return REL_EQ;
 303     } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') {
 304         return REL_LE;
 305     } elsif ($op eq '<<' or $op eq 'lt') {
 306         return REL_LT;
 307     } else {
 308         croak "bad relation '$op'";
 309     }
 310 }
 311
 312 =item version_compare_string($a, $b)
 313
 314 String comparison function used for comparing non-numerical parts of version
 315 numbers. Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a
 316 is later than $b.
 317
 318 The "~" character always sort lower than anything else. Digits sort lower
 319 than non-digits. Among remaining characters alphabetic characters (A-Z, a-z)
 320 sort lower than the other ones. Within each range, the ASCII decimal value
 321 of the character is used to sort between characters.
 322
 323 =cut
 324
 325 sub _version_order {
 326     my $x = shift;
 327
 328     if ($x eq '~') {
 329         return -1;
 330     } elsif ($x =~ /^\d$/) {
 331         return $x * 1 + 1;
 332     } elsif ($x =~ /^[A-Za-z]$/) {
 333         return ord($x);
 334     } else {
 335         return ord($x) + 256;
 336     }
 337 }
 338
 339 sub version_compare_string($$) {
 340     my @a = map { _version_order($_) } split(//, shift);
 341     my @b = map { _version_order($_) } split(//, shift);
 342     while (1) {
 343         my ($a, $b) = (shift @a, shift @b);
 344         return 0 if not defined($a) and not defined($b);
 345         $a ||= 0; # Default order for "no character"
 346         $b ||= 0;
 347         return 1 if $a > $b;
 348         return -1 if $a < $b;
 349     }
 350 }
 351
 352 =item version_compare_part($a, $b)
 353
 354 Compare two corresponding sub-parts of a version number (either upstream
 355 version or debian revision).
 356
 357 Each parameter is split by version_split_digits() and resulting items
 358 are compared together. As soon as a difference happens, it returns -1 if
 359 $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b.
 360
 361 =cut
 362
 363 sub version_compare_part($$) {
 364     my @a = version_split_digits(shift);
 365     my @b = version_split_digits(shift);
 366     while (1) {
 367         my ($a, $b) = (shift @a, shift @b);
 368         return 0 if not defined($a) and not defined($b);
 369         $a ||= 0; # Default value for lack of version
 370         $b ||= 0;
 371         if ($a =~ /^\d+$/ and $b =~ /^\d+$/) {
 372             # Numerical comparison
 373             my $cmp = $a <=> $b;
 374             return $cmp if $cmp;
 375         } else {
 376             # String comparison
 377             my $cmp = version_compare_string($a, $b);
 378             return $cmp if $cmp;
 379         }
 380     }
 381 }
 382
 383 =item @items = version_split_digits($version)
 384
 385 Splits a string in items that are each entirely composed either
 386 of digits or of non-digits. For instance for "1.024~beta1+svn234" it would
 387 return ("1", ".", "024", "~beta", "1", "+svn", "234").
 388
 389 =cut
 390
 391 sub version_split_digits($) {
 392     my $version = shift;
 393
 394     return split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $version;
 395 }
 396
 397 =item ($ok, $msg) = version_check($version)
 398
 399 =item $ok = version_check($version)
 400
 401 Checks the validity of $version as a version number. Returns 1 in $ok
 402 if the version is valid, 0 otherwise. In the latter case, $msg
 403 contains a description of the problem with the $version scalar.
 404
 405 =cut
 406
 407 sub version_check($) {
 408     my $version = shift;
 409     my $str;
 410     if (defined $version) {
 411         $str = "$version";
 412         $version = Dpkg::Version->new($str) unless ref($version);
 413     }
 414     if (not defined($str) or not length($str)) {
 415         my $msg = g_('version number cannot be empty');
 416         return (0, $msg) if wantarray;
 417         return 0;
 418     }
 419     if (not defined $version->epoch() or not length $version->epoch()) {
 420         my $msg = sprintf(g_('epoch part of the version number cannot be empty'));
 421         return (0, $msg) if wantarray;
 422         return 0;
 423     }
 424     if (not defined $version->version() or not length $version->version()) {
 425         my $msg = g_('upstream version cannot be empty');
 426         return (0, $msg) if wantarray;
 427         return 0;
 428     }
 429     if (not defined $version->revision() or not length $version->revision()) {
 430         my $msg = sprintf(g_('revision cannot be empty'));
 431         return (0, $msg) if wantarray;
 432         return 0;
 433     }
 434     if ($version->version() =~ m/^[^\d]/) {
 435         my $msg = g_('version number does not start with digit');
 436         return (0, $msg) if wantarray;
 437         return 0;
 438     }
 439     if ($str =~ m/([^-+:.0-9a-zA-Z~])/o) {
 440         my $msg = sprintf g_("version number contains illegal character '%s'"), $1;
 441         return (0, $msg) if wantarray;
 442         return 0;
 443     }
 444     if ($version->epoch() !~ /^\d*$/) {
 445         my $msg = sprintf(g_('epoch part of the version number ' .
 446                              "is not a number: '%s'"), $version->epoch());
 447         return (0, $msg) if wantarray;
 448         return 0;
 449     }
 450     return (1, '') if wantarray;
 451     return 1;
 452 }
 453
 454 =back
 455
 456 =head1 CHANGES
 457
 458 =head2 Version 1.01 (dpkg 1.17.0)
 459
 460 New argument: Accept an options argument in $v->as_string().
 461
 462 New method: $v->is_native().
 463
 464 =head2 Version 1.00 (dpkg 1.15.6)
 465
 466 Mark the module as public.
 467
 468 =cut
 469
 470 1;