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