File: | Dpkg/Version.pm |
Coverage: | 93.5% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
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 | 541 541 541 | 1083 534 7502 | use strict; | ||||
22 | 541 541 541 | 1066 19 11778 | use warnings; | ||||
23 | 541 541 541 | 1586 536 27365 | use warnings::register qw(semantic_change::overload::bool); | ||||
24 | |||||||
25 | our $VERSION = '1.03'; | ||||||
26 | our @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 | |||||||
41 | 541 541 541 | 1598 1055 7498 | use Exporter qw(import); | ||||
42 | 541 541 541 | 1068 535 13404 | use Carp; | ||||
43 | |||||||
44 | 541 541 541 | 1068 15 12864 | use Dpkg::Gettext; | ||||
45 | 541 541 541 | 1087 524 18825 | use Dpkg::ErrorHandling; | ||||
46 | |||||||
47 | use constant { | ||||||
48 | 541 | 47034 | REL_LT => '<<', | ||||
49 | REL_LE => '<=', | ||||||
50 | REL_EQ => '=', | ||||||
51 | REL_GE => '>=', | ||||||
52 | REL_GT => '>>', | ||||||
53 | 541 541 | 1594 13 | }; | ||||
54 | |||||||
55 | use overload | ||||||
56 | '<=>' => \&_comparison, | ||||||
57 | 'cmp' => \&_comparison, | ||||||
58 | 29904 | 62376 | '""' => sub { return $_[0]->as_string(); }, | ||||
59 | 1242 | 1585 | 'bool' => sub { return $_[0]->is_valid(); }, | ||||
60 | 541 541 541 | 74617 395614 2710 | 'fallback' => 1; | ||||
61 | |||||||
62 | =encoding utf8 | ||||||
63 | |||||||
64 - 91 | =head1 NAME 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) and also an object oriented interface overriding perl operators to do the right thing when you compare Dpkg::Version object between them. =head1 METHODS =over 4 =item $v = Dpkg::Version->new($version, %opts) Create a new Dpkg::Version object corresponding to the version indicated in the string (scalar) $version. By default it will accepts any string and consider it as a valid version. If you pass the option "check => 1", it will return undef if the version is invalid (see version_check for details). You can always call $v->is_valid() later on to verify that the version is valid. =cut | ||||||
92 | |||||||
93 | sub new { | ||||||
94 | 674870 | 1 | 1331067 | my ($this, $ver, %opts) = @_; | |||
95 | 674870 | 2228832 | my $class = ref($this) || $this; | ||||
96 | 674870 | 789438 | $ver = "$ver" if ref($ver); # Try to stringify objects | ||||
97 | |||||||
98 | 674870 | 1042237 | if ($opts{check}) { | ||||
99 | 331717 | 567927 | return unless version_check($ver); | ||||
100 | } | ||||||
101 | |||||||
102 | 674870 | 596586 | my $self = {}; | ||||
103 | 674870 | 1182304 | if ($ver =~ /^([^:]*):(.+)$/) { | ||||
104 | 82205 | 193725 | $self->{epoch} = $1; | ||||
105 | 82205 | 111140 | $ver = $2; | ||||
106 | } else { | ||||||
107 | 592665 | 703807 | $self->{epoch} = 0; | ||||
108 | 592665 | 598585 | $self->{no_epoch} = 1; | ||||
109 | } | ||||||
110 | 674870 | 1214420 | if ($ver =~ /(.*)-(.*)$/) { | ||||
111 | 278047 | 594236 | $self->{version} = $1; | ||||
112 | 278047 | 338503 | $self->{revision} = $2; | ||||
113 | } else { | ||||||
114 | 396823 | 650193 | $self->{version} = $ver; | ||||
115 | 396823 | 352300 | $self->{revision} = 0; | ||||
116 | 396823 | 421320 | $self->{no_revision} = 1; | ||||
117 | } | ||||||
118 | |||||||
119 | 674870 | 816454 | return bless $self, $class; | ||||
120 | } | ||||||
121 | |||||||
122 - 144 | =item boolean evaluation When the Dpkg::Version object is used in a boolean evaluation (for example in "if ($v)" or "$v ? \"$v\" : 'default'") it returns true if the version stored is valid ($v->is_valid()) and false otherwise. B<Notice>: Between dpkg 1.15.7.2 and 1.19.1 this overload used to return $v->as_string() if $v->is_valid(), a breaking change in behavior that caused "0" versions to be evaluated as false. To catch any possibly intended code that relied on those semantics, this overload will emit a warning with category "Dpkg::Version::semantic_change::overload::bool" until dpkg 1.20.x. Once fixed, or for already valid code the warning can be quiesced with no if $Dpkg::Version::VERSION ge '1.02', warnings => qw(Dpkg::Version::semantic_change::overload::bool); added after the C<use Dpkg::Version>. =item $v->is_valid() Returns true if the version is valid, false otherwise. =cut | ||||||
145 | |||||||
146 | sub is_valid { | ||||||
147 | 5945 | 1 | 4001 | my $self = shift; | |||
148 | 5945 | 5125 | return scalar version_check($self); | ||||
149 | } | ||||||
150 | |||||||
151 - 155 | =item $v->epoch(), $v->version(), $v->revision() Returns the corresponding part of the full version string. =cut | ||||||
156 | |||||||
157 | sub epoch { | ||||||
158 | 1616844 | 1 | 1438009 | my $self = shift; | |||
159 | 1616844 | 3525783 | return $self->{epoch}; | ||||
160 | } | ||||||
161 | |||||||
162 | sub version { | ||||||
163 | 1569462 | 1 | 1193130 | my $self = shift; | |||
164 | 1569462 | 2886659 | return $self->{version}; | ||||
165 | } | ||||||
166 | |||||||
167 | sub revision { | ||||||
168 | 875356 | 1 | 540292 | my $self = shift; | |||
169 | 875356 | 1525753 | return $self->{revision}; | ||||
170 | } | ||||||
171 | |||||||
172 - 176 | =item $v->is_native() Returns true if the version is native, false if it has a revision. =cut | ||||||
177 | |||||||
178 | sub is_native { | ||||||
179 | 2585 | 1 | 2068 | my $self = shift; | |||
180 | 2585 | 4136 | return $self->{no_revision}; | ||||
181 | } | ||||||
182 | |||||||
183 - 189 | =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 | ||||||
190 | |||||||
191 | sub _comparison { | ||||||
192 | 303520 | 499914 | my ($a, $b, $inverted) = @_; | ||||
193 | 303520 | 1111292 | if (not ref($b) or not $b->isa('Dpkg::Version')) { | ||||
194 | 3683 | 4187 | $b = Dpkg::Version->new($b); | ||||
195 | } | ||||||
196 | 303520 | 616503 | ($a, $b) = ($b, $a) if $inverted; | ||||
197 | 303520 | 428840 | my $r = version_compare_part($a->epoch(), $b->epoch()); | ||||
198 | 303520 | 403049 | return $r if $r; | ||||
199 | 280086 | 280591 | $r = version_compare_part($a->version(), $b->version()); | ||||
200 | 280086 | 675990 | return $r if $r; | ||||
201 | 101765 | 83386 | return version_compare_part($a->revision(), $b->revision()); | ||||
202 | } | ||||||
203 | |||||||
204 - 224 | =item "$v", $v->as_string(), $v->as_string(%options) Accepts an optional option hash reference, affecting the string conversion. Options: =over 8 =item omit_epoch (defaults to 0) Omit the epoch, if present, in the output string. =item omit_revision (defaults to 0) Omit the revision, if present, in the output string. =back Returns the string representation of the version number. =cut | ||||||
225 | |||||||
226 | sub as_string { | ||||||
227 | 34128 | 1 | 34196 | my ($self, %opts) = @_; | |||
228 | 34128 | 118310 | my $no_epoch = $opts{omit_epoch} || $self->{no_epoch}; | ||||
229 | 34128 | 75105 | my $no_revision = $opts{omit_revision} || $self->{no_revision}; | ||||
230 | |||||||
231 | 34128 | 30508 | my $str = ''; | ||||
232 | 34128 | 44206 | $str .= $self->{epoch} . ':' unless $no_epoch; | ||||
233 | 34128 | 32791 | $str .= $self->{version}; | ||||
234 | 34128 | 35621 | $str .= '-' . $self->{revision} unless $no_revision; | ||||
235 | 34128 | 111398 | return $str; | ||||
236 | } | ||||||
237 | |||||||
238 | =back | ||||||
239 | |||||||
240 - 253 | =head1 FUNCTIONS All the functions are exported by default. =over 4 =item version_compare($a, $b) Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. If $a or $b are not valid version numbers, it dies with an error. =cut | ||||||
254 | |||||||
255 | sub version_compare($$) { | ||||||
256 | 154462 | 1 | 448429 | my ($a, $b) = @_; | |||
257 | 154462 | 1470707 | my $va = Dpkg::Version->new($a, check => 1); | ||||
258 | 154462 | 213075 | defined($va) || error(g_('%s is not a valid version'), "$a"); | ||||
259 | 154462 | 196485 | my $vb = Dpkg::Version->new($b, check => 1); | ||||
260 | 154462 | 199399 | defined($vb) || error(g_('%s is not a valid version'), "$b"); | ||||
261 | 154462 | 443172 | return $va <=> $vb; | ||||
262 | } | ||||||
263 | |||||||
264 - 273 | =item version_compare_relation($a, $rel, $b) Returns the result (0 or 1) of the given comparison operation. This function is implemented on top of version_compare(). Allowed values for $rel are the exported constants REL_GT, REL_GE, REL_EQ, REL_LE, REL_LT. Use version_normalize_relation() if you have an input string containing the operator. =cut | ||||||
274 | |||||||
275 | sub version_compare_relation($$$) { | ||||||
276 | 133919 | 1 | 297609 | my ($a, $op, $b) = @_; | |||
277 | 133919 | 520309 | my $res = version_compare($a, $b); | ||||
278 | |||||||
279 | 133919 | 342333 | if ($op eq REL_GT) { | ||||
280 | 21887 | 117071 | return $res > 0; | ||||
281 | } elsif ($op eq REL_GE) { | ||||||
282 | 33156 | 146741 | return $res >= 0; | ||||
283 | } elsif ($op eq REL_EQ) { | ||||||
284 | 22317 | 100453 | return $res == 0; | ||||
285 | } elsif ($op eq REL_LE) { | ||||||
286 | 33884 | 140731 | return $res <= 0; | ||||
287 | } elsif ($op eq REL_LT) { | ||||||
288 | 22675 | 101166 | return $res < 0; | ||||
289 | } else { | ||||||
290 | 0 | 0 | croak "unsupported relation for version_compare_relation(): '$op'"; | ||||
291 | } | ||||||
292 | } | ||||||
293 | |||||||
294 - 302 | =item $rel = version_normalize_relation($rel_string) Returns the normalized constant of the relation $rel (a value among REL_GT, REL_GE, REL_EQ, REL_LE and REL_LT). Supported relations 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 | ||||||
303 | |||||||
304 | sub version_normalize_relation($) { | ||||||
305 | 133948 | 1 | 417998 | my $op = shift; | |||
306 | |||||||
307 | 133948 | 1171558 | warning('relation %s is deprecated: use %s or %s', | ||||
308 | $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<'); | ||||||
309 | |||||||
310 | 133948 | 2120203 | if ($op eq '>>' or $op eq 'gt') { | ||||
311 | 21891 | 75332 | return REL_GT; | ||||
312 | } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') { | ||||||
313 | 33178 | 50131 | return REL_GE; | ||||
314 | } elsif ($op eq '=' or $op eq 'eq') { | ||||||
315 | 22327 | 52117 | return REL_EQ; | ||||
316 | } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') { | ||||||
317 | 33888 | 59320 | return REL_LE; | ||||
318 | } elsif ($op eq '<<' or $op eq 'lt') { | ||||||
319 | 22664 | 38212 | return REL_LT; | ||||
320 | } else { | ||||||
321 | 0 | 0 | croak "bad relation '$op'"; | ||||
322 | } | ||||||
323 | } | ||||||
324 | |||||||
325 - 336 | =item version_compare_string($a, $b) String comparison function used for comparing non-numerical parts of version numbers. Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. The "~" character always sort lower than anything else. Digits sort lower than non-digits. Among remaining characters alphabetic characters (A-Z, a-z) sort lower than the other ones. Within each range, the ASCII decimal value of the character is used to sort between characters. =cut | ||||||
337 | |||||||
338 | sub _version_order { | ||||||
339 | 1988419 | 1279104 | my $x = shift; | ||||
340 | |||||||
341 | 1988419 | 2477670 | if ($x eq '~') { | ||||
342 | 93847 | 106417 | return -1; | ||||
343 | } elsif ($x =~ /^\d$/) { | ||||||
344 | 50326 | 57245 | return $x * 1 + 1; | ||||
345 | } elsif ($x =~ /^[A-Za-z]$/) { | ||||||
346 | 1467963 | 1178571 | return ord($x); | ||||
347 | } else { | ||||||
348 | 376283 | 368698 | return ord($x) + 256; | ||||
349 | } | ||||||
350 | } | ||||||
351 | |||||||
352 | sub version_compare_string($$) { | ||||||
353 | 326887 1033604 | 1 | 416116 663835 | my @a = map { _version_order($_) } split(//, shift); | |||
354 | 326887 954815 | 345738 565598 | my @b = map { _version_order($_) } split(//, shift); | ||||
355 | 326887 | 220390 | while (1) { | ||||
356 | 1124589 | 901743 | my ($a, $b) = (shift @a, shift @b); | ||||
357 | 1124589 | 1258485 | return 0 if not defined($a) and not defined($b); | ||||
358 | 922474 | 668991 | $a ||= 0; # Default order for "no character" | ||||
359 | 922474 | 749328 | $b ||= 0; | ||||
360 | 922474 | 707684 | return 1 if $a > $b; | ||||
361 | 865188 | 693937 | return -1 if $a < $b; | ||||
362 | } | ||||||
363 | } | ||||||
364 | |||||||
365 - 374 | =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. As soon as a difference happens, it returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. =cut | ||||||
375 | |||||||
376 | sub version_compare_part($$) { | ||||||
377 | 685371 | 1 | 838264 | my @a = version_split_digits(shift); | |||
378 | 685371 | 652378 | my @b = version_split_digits(shift); | ||||
379 | 685371 | 409410 | while (1) { | ||||
380 | 1622168 | 1309597 | my ($a, $b) = (shift @a, shift @b); | ||||
381 | 1622168 | 3037996 | return 0 if not defined($a) and not defined($b); | ||||
382 | 1154808 | 2225481 | $a ||= 0; # Default value for lack of version | ||||
383 | 1154808 | 1979995 | $b ||= 0; | ||||
384 | 1154808 | 2893376 | if ($a =~ /^\d+$/ and $b =~ /^\d+$/) { | ||||
385 | # Numerical comparison | ||||||
386 | 827921 | 598833 | my $cmp = $a <=> $b; | ||||
387 | 827921 | 734987 | return $cmp if $cmp; | ||||
388 | } else { | ||||||
389 | # String comparison | ||||||
390 | 326887 | 455155 | my $cmp = version_compare_string($a, $b); | ||||
391 | 326887 | 343629 | return $cmp if $cmp; | ||||
392 | } | ||||||
393 | } | ||||||
394 | } | ||||||
395 | |||||||
396 - 402 | =item @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 | ||||||
403 | |||||||
404 | sub version_split_digits($) { | ||||||
405 | 1370742 | 1 | 972782 | my $version = shift; | |||
406 | |||||||
407 | 1370742 | 3285350 | return split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $version; | ||||
408 | } | ||||||
409 | |||||||
410 - 418 | =item ($ok, $msg) = version_check($version) =item $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 | ||||||
419 | |||||||
420 | sub version_check($) { | ||||||
421 | 337981 | 1 | 420457 | my $version = shift; | |||
422 | 337981 | 253568 | my $str; | ||||
423 | 337981 | 358854 | if (defined $version) { | ||||
424 | 337981 | 384953 | $str = "$version"; | ||||
425 | 337981 | 683068 | $version = Dpkg::Version->new($str) unless ref($version); | ||||
426 | } | ||||||
427 | 337981 | 1471546 | if (not defined($str) or not length($str)) { | ||||
428 | 517 | 1551 | my $msg = g_('version number cannot be empty'); | ||||
429 | 517 | 517 | return (0, $msg) if wantarray; | ||||
430 | 517 | 1034 | return 0; | ||||
431 | } | ||||||
432 | 337464 | 595081 | if (not defined $version->epoch() or not length $version->epoch()) { | ||||
433 | 517 | 517 | my $msg = sprintf(g_('epoch part of the version number cannot be empty')); | ||||
434 | 517 | 3619 | return (0, $msg) if wantarray; | ||||
435 | 517 | 1034 | return 0; | ||||
436 | } | ||||||
437 | 336947 | 523137 | if (not defined $version->version() or not length $version->version()) { | ||||
438 | 1034 | 1551 | my $msg = g_('upstream version cannot be empty'); | ||||
439 | 1034 | 1551 | return (0, $msg) if wantarray; | ||||
440 | 1034 | 2068 | return 0; | ||||
441 | } | ||||||
442 | 335913 | 585249 | if (not defined $version->revision() or not length $version->revision()) { | ||||
443 | 517 | 517 | my $msg = sprintf(g_('revision cannot be empty')); | ||||
444 | 517 | 517 | return (0, $msg) if wantarray; | ||||
445 | 517 | 1034 | return 0; | ||||
446 | } | ||||||
447 | 335396 | 322125 | if ($version->version() =~ m/^[^\d]/) { | ||||
448 | 1037 | 1555 | my $msg = g_('version number does not start with digit'); | ||||
449 | 1037 | 1038 | return (0, $msg) if wantarray; | ||||
450 | 1034 | 2068 | return 0; | ||||
451 | } | ||||||
452 | 334359 | 431342 | if ($str =~ m/([^-+:.0-9a-zA-Z~])/o) { | ||||
453 | 517 | 517 | my $msg = sprintf g_("version number contains illegal character '%s'"), $1; | ||||
454 | 517 | 1034 | return (0, $msg) if wantarray; | ||||
455 | 517 | 1034 | return 0; | ||||
456 | } | ||||||
457 | 333842 | 283593 | if ($version->epoch() !~ /^\d*$/) { | ||||
458 | 1034 | 1551 | my $msg = sprintf(g_('epoch part of the version number ' . | ||||
459 | "is not a number: '%s'"), $version->epoch()); | ||||||
460 | 1034 | 1034 | return (0, $msg) if wantarray; | ||||
461 | 1034 | 2068 | return 0; | ||||
462 | } | ||||||
463 | 332808 | 478836 | return (1, '') if wantarray; | ||||
464 | 332492 | 488016 | return 1; | ||||
465 | } | ||||||
466 | |||||||
467 | =back | ||||||
468 | |||||||
469 - 489 | =head1 CHANGES =head2 Version 1.03 (dpkg 1.20.0) Remove deprecation warning from semantic change in 1.02. =head2 Version 1.02 (dpkg 1.19.1) Semantic change: bool evaluation semantics restored to their original behavior. =head2 Version 1.01 (dpkg 1.17.0) New argument: Accept an options argument in $v->as_string(). New method: $v->is_native(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut | ||||||
490 | |||||||
491 | 1; |