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