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 | =encoding utf8 | ||||||
20 | |||||||
21 - 33 | =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. =cut | ||||||
34 | |||||||
35 | package Dpkg::Version 1.03; | ||||||
36 | |||||||
37 | 1626 1626 1626 | 14690 2199 77868 | use strict; | ||||
38 | 1626 1626 1626 | 5302 1081 110399 | use warnings; | ||||
39 | # Currently unused, but not removed to not generate warnings on users. | ||||||
40 | 1626 1626 1626 | 9464 2112 137067 | 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 | 1626 1626 1626 | 5875 1076 40901 | use Exporter qw(import); | ||||
58 | 1626 1626 1626 | 4264 1617 62841 | use Carp; | ||||
59 | |||||||
60 | 1626 1626 1626 | 3784 3165 48052 | use Dpkg::Gettext; | ||||
61 | 1626 1626 1626 | 4835 1078 78341 | use Dpkg::ErrorHandling; | ||||
62 | |||||||
63 | use constant { | ||||||
64 | 1626 | 170009 | REL_LT => '<<', | ||||
65 | REL_LE => '<=', | ||||||
66 | REL_EQ => '=', | ||||||
67 | REL_GE => '>=', | ||||||
68 | REL_GT => '>>', | ||||||
69 | 1626 1626 | 3793 1635 | }; | ||||
70 | |||||||
71 | use overload | ||||||
72 | '<=>' => \&_comparison, | ||||||
73 | 'cmp' => \&_comparison, | ||||||
74 | 89742 | 231196 | '""' => sub { return $_[0]->as_string(); }, | ||||
75 | 3735 | 5307 | 'bool' => sub { return $_[0]->is_valid(); }, | ||||
76 | 1626 1626 1626 | 280800 1531648 28883 | 'fallback' => 1; | ||||
77 | |||||||
78 - 93 | =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 | ||||||
94 | |||||||
95 | sub new { | ||||||
96 | 2024684 | 1 | 3787608 | my ($this, $ver, %opts) = @_; | |||
97 | 2024684 | 5826291 | my $class = ref($this) || $this; | ||||
98 | 2024684 | 2071501 | $ver = "$ver" if ref($ver); # Try to stringify objects | ||||
99 | |||||||
100 | 2024684 | 2716139 | if ($opts{check}) { | ||||
101 | 995173 | 1917911 | return unless version_check($ver); | ||||
102 | } | ||||||
103 | |||||||
104 | 2024684 | 1637945 | my $self = {}; | ||||
105 | 2024684 | 3765425 | if ($ver =~ /^([^:]*):(.+)$/) { | ||||
106 | 246615 | 572808 | $self->{epoch} = $1; | ||||
107 | 246615 | 327950 | $ver = $2; | ||||
108 | } else { | ||||||
109 | 1778069 | 2208751 | $self->{epoch} = 0; | ||||
110 | 1778069 | 1713104 | $self->{no_epoch} = 1; | ||||
111 | } | ||||||
112 | 2024684 | 3986419 | if ($ver =~ /(.*)-(.*)$/) { | ||||
113 | 834141 | 1498545 | $self->{version} = $1; | ||||
114 | 834141 | 1137254 | $self->{revision} = $2; | ||||
115 | } else { | ||||||
116 | 1190543 | 1425512 | $self->{version} = $ver; | ||||
117 | 1190543 | 1216184 | $self->{revision} = 0; | ||||
118 | 1190543 | 966124 | $self->{no_revision} = 1; | ||||
119 | } | ||||||
120 | |||||||
121 | 2024684 | 2764341 | return bless $self, $class; | ||||
122 | } | ||||||
123 | |||||||
124 - 147 | =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 emitted a warning with category "Dpkg::Version::semantic_change::overload::bool" between dpkg 1.19.1 and 1.20.0. Once fixed, or for already valid code the warning could be quiesced for that specific versions with no if $Dpkg::Version::VERSION eq '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 | ||||||
148 | |||||||
149 | sub is_valid { | ||||||
150 | 17844 | 1 | 17610 | my $self = shift; | |||
151 | 17844 | 23480 | return scalar version_check($self); | ||||
152 | } | ||||||
153 | |||||||
154 - 158 | =item $v->epoch(), $v->version(), $v->revision() Returns the corresponding part of the full version string. =cut | ||||||
159 | |||||||
160 | sub epoch { | ||||||
161 | 4850671 | 1 | 3760731 | my $self = shift; | |||
162 | 4850671 | 10138644 | return $self->{epoch}; | ||||
163 | } | ||||||
164 | |||||||
165 | sub version { | ||||||
166 | 4708525 | 1 | 3330352 | my $self = shift; | |||
167 | 4708525 | 9382391 | return $self->{version}; | ||||
168 | } | ||||||
169 | |||||||
170 | sub revision { | ||||||
171 | 2626130 | 1 | 1719301 | my $self = shift; | |||
172 | 2626130 | 5167746 | return $self->{revision}; | ||||
173 | } | ||||||
174 | |||||||
175 - 179 | =item $v->is_native() Returns true if the version is native, false if it has a revision. =cut | ||||||
180 | |||||||
181 | sub is_native { | ||||||
182 | 7755 | 1 | 5687 | my $self = shift; | |||
183 | 7755 | 11891 | return $self->{no_revision}; | ||||
184 | } | ||||||
185 | |||||||
186 - 192 | =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 | ||||||
193 | |||||||
194 | sub _comparison { | ||||||
195 | 910583 | 1518227 | my ($a, $b, $inverted) = @_; | ||||
196 | 910583 | 4191577 | if (not ref($b) or not $b->isa('Dpkg::Version')) { | ||||
197 | 11058 | 18861 | $b = Dpkg::Version->new($b); | ||||
198 | } | ||||||
199 | 910583 | 1720142 | ($a, $b) = ($b, $a) if $inverted; | ||||
200 | 910583 | 1492657 | my $r = version_compare_part($a->epoch(), $b->epoch()); | ||||
201 | 910583 | 1210180 | return $r if $r; | ||||
202 | 840281 | 943881 | $r = version_compare_part($a->version(), $b->version()); | ||||
203 | 840281 | 2723274 | return $r if $r; | ||||
204 | 305295 | 332569 | return version_compare_part($a->revision(), $b->revision()); | ||||
205 | } | ||||||
206 | |||||||
207 - 227 | =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 | ||||||
228 | |||||||
229 | sub as_string { | ||||||
230 | 102414 | 1 | 143540 | my ($self, %opts) = @_; | |||
231 | 102414 | 407396 | my $no_epoch = $opts{omit_epoch} || $self->{no_epoch}; | ||||
232 | 102414 | 295981 | my $no_revision = $opts{omit_revision} || $self->{no_revision}; | ||||
233 | |||||||
234 | 102414 | 122326 | my $str = ''; | ||||
235 | 102414 | 129174 | $str .= $self->{epoch} . ':' unless $no_epoch; | ||||
236 | 102414 | 98004 | $str .= $self->{version}; | ||||
237 | 102414 | 134641 | $str .= '-' . $self->{revision} unless $no_revision; | ||||
238 | 102414 | 419171 | return $str; | ||||
239 | } | ||||||
240 | |||||||
241 | =back | ||||||
242 | |||||||
243 - 256 | =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 | ||||||
257 | |||||||
258 | sub version_compare($$) { | ||||||
259 | 463397 | 1 | 1405981 | my ($a, $b) = @_; | |||
260 | 463397 | 3872715 | my $va = Dpkg::Version->new($a, check => 1); | ||||
261 | 463397 | 755598 | defined($va) || error(g_('%s is not a valid version'), "$a"); | ||||
262 | 463397 | 715052 | my $vb = Dpkg::Version->new($b, check => 1); | ||||
263 | 463397 | 720890 | defined($vb) || error(g_('%s is not a valid version'), "$b"); | ||||
264 | 463397 | 2033611 | return $va <=> $vb; | ||||
265 | } | ||||||
266 | |||||||
267 - 276 | =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 | ||||||
277 | |||||||
278 | sub version_compare_relation($$$) { | ||||||
279 | 401757 | 1 | 1550422 | my ($a, $op, $b) = @_; | |||
280 | 401757 | 954021 | my $res = version_compare($a, $b); | ||||
281 | |||||||
282 | 401757 | 1248610 | if ($op eq REL_GT) { | ||||
283 | 65661 | 346892 | return $res > 0; | ||||
284 | } elsif ($op eq REL_GE) { | ||||||
285 | 99468 | 529881 | return $res >= 0; | ||||
286 | } elsif ($op eq REL_EQ) { | ||||||
287 | 66951 | 351940 | return $res == 0; | ||||
288 | } elsif ($op eq REL_LE) { | ||||||
289 | 101652 | 450983 | return $res <= 0; | ||||
290 | } elsif ($op eq REL_LT) { | ||||||
291 | 68025 | 321370 | return $res < 0; | ||||
292 | } else { | ||||||
293 | 0 | 0 | croak "unsupported relation for version_compare_relation(): '$op'"; | ||||
294 | } | ||||||
295 | } | ||||||
296 | |||||||
297 - 305 | =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 | ||||||
306 | |||||||
307 | sub version_normalize_relation($) { | ||||||
308 | 401865 | 1 | 1199923 | my $op = shift; | |||
309 | |||||||
310 | 401865 | 3232894 | warning('relation %s is deprecated: use %s or %s', | ||||
311 | $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<'); | ||||||
312 | |||||||
313 | 401865 | 5374793 | if ($op eq '>>' or $op eq 'gt') { | ||||
314 | 65673 | 173338 | return REL_GT; | ||||
315 | } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') { | ||||||
316 | 99537 | 253282 | return REL_GE; | ||||
317 | } elsif ($op eq '=' or $op eq 'eq') { | ||||||
318 | 66999 | 182690 | return REL_EQ; | ||||
319 | } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') { | ||||||
320 | 101664 | 231089 | return REL_LE; | ||||
321 | } elsif ($op eq '<<' or $op eq 'lt') { | ||||||
322 | 67992 | 139007 | return REL_LT; | ||||
323 | } else { | ||||||
324 | 0 | 0 | croak "bad relation '$op'"; | ||||
325 | } | ||||||
326 | } | ||||||
327 | |||||||
328 - 339 | =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 | ||||||
340 | |||||||
341 | sub _version_order { | ||||||
342 | 5965237 | 3923198 | my $x = shift; | ||||
343 | |||||||
344 | 5965237 | 8288183 | if ($x eq '~') { | ||||
345 | 281541 | 378697 | return -1; | ||||
346 | } elsif ($x =~ /^\d$/) { | ||||||
347 | 150978 | 268461 | return $x * 1 + 1; | ||||
348 | } elsif ($x =~ /^[A-Za-z]$/) { | ||||||
349 | 4403889 | 3847772 | return ord($x); | ||||
350 | } else { | ||||||
351 | 1128829 | 1313475 | return ord($x) + 256; | ||||
352 | } | ||||||
353 | } | ||||||
354 | |||||||
355 | sub version_compare_string($$) { | ||||||
356 | 980651 3100802 | 1 | 1658618 2498865 | my @a = map { _version_order($_) } split(//, shift); | |||
357 | 980651 2864435 | 1296162 1902649 | my @b = map { _version_order($_) } split(//, shift); | ||||
358 | 980651 | 810739 | while (1) { | ||||
359 | 3373747 | 2493030 | my ($a, $b) = (shift @a, shift @b); | ||||
360 | 3373747 | 4268252 | return 0 if not defined($a) and not defined($b); | ||||
361 | 2767412 | 2090168 | $a ||= 0; # Default order for "no character" | ||||
362 | 2767412 | 2453371 | $b ||= 0; | ||||
363 | 2767412 | 2244280 | return 1 if $a > $b; | ||||
364 | 2595550 | 2184315 | return -1 if $a < $b; | ||||
365 | } | ||||||
366 | } | ||||||
367 | |||||||
368 - 377 | =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 | ||||||
378 | |||||||
379 | sub version_compare_part($$) { | ||||||
380 | 2056159 | 1 | 2624319 | my @a = version_split_digits(shift); | |||
381 | 2056159 | 2246531 | my @b = version_split_digits(shift); | ||||
382 | 2056159 | 1598304 | while (1) { | ||||
383 | 4866553 | 4278704 | my ($a, $b) = (shift @a, shift @b); | ||||
384 | 4866553 | 7924084 | return 0 if not defined($a) and not defined($b); | ||||
385 | 3464450 | 7271073 | $a ||= 0; # Default value for lack of version | ||||
386 | 3464450 | 6389025 | $b ||= 0; | ||||
387 | 3464450 | 9656830 | if ($a =~ /^\d+$/ and $b =~ /^\d+$/) { | ||||
388 | # Numerical comparison | ||||||
389 | 2483799 | 2072579 | my $cmp = $a <=> $b; | ||||
390 | 2483799 | 2899829 | return $cmp if $cmp; | ||||
391 | } else { | ||||||
392 | # String comparison | ||||||
393 | 980651 | 1522817 | my $cmp = version_compare_string($a, $b); | ||||
394 | 980651 | 1395412 | return $cmp if $cmp; | ||||
395 | } | ||||||
396 | } | ||||||
397 | } | ||||||
398 | |||||||
399 - 405 | =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 | ||||||
406 | |||||||
407 | sub version_split_digits($) { | ||||||
408 | 4112318 | 1 | 2944614 | my $version = shift; | |||
409 | |||||||
410 | 4112318 | 10876044 | return split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $version; | ||||
411 | } | ||||||
412 | |||||||
413 - 421 | =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 | ||||||
422 | |||||||
423 | sub version_check($) { | ||||||
424 | 1013974 | 1 | 1514019 | my $version = shift; | |||
425 | 1013974 | 1141694 | my $str; | ||||
426 | 1013974 | 1302583 | if (defined $version) { | ||||
427 | 1013974 | 1070096 | $str = "$version"; | ||||
428 | 1013974 | 1969427 | $version = Dpkg::Version->new($str) unless ref($version); | ||||
429 | } | ||||||
430 | 1013974 | 3990792 | if (not defined($str) or not length($str)) { | ||||
431 | 1551 | 4653 | my $msg = g_('version number cannot be empty'); | ||||
432 | 1551 | 2585 | return (0, $msg) if wantarray; | ||||
433 | 1551 | 3102 | return 0; | ||||
434 | } | ||||||
435 | 1012423 | 1926817 | if (not defined $version->epoch() or not length $version->epoch()) { | ||||
436 | 1551 | 4653 | my $msg = sprintf(g_('epoch part of the version number cannot be empty')); | ||||
437 | 1551 | 3619 | return (0, $msg) if wantarray; | ||||
438 | 1551 | 7755 | return 0; | ||||
439 | } | ||||||
440 | 1010872 | 1504252 | if (not defined $version->version() or not length $version->version()) { | ||||
441 | 3102 | 6721 | my $msg = g_('upstream version cannot be empty'); | ||||
442 | 3102 | 4136 | return (0, $msg) if wantarray; | ||||
443 | 3102 | 9823 | return 0; | ||||
444 | } | ||||||
445 | 1007770 | 1835185 | if (not defined $version->revision() or not length $version->revision()) { | ||||
446 | 1551 | 8272 | my $msg = sprintf(g_('revision cannot be empty')); | ||||
447 | 1551 | 2585 | return (0, $msg) if wantarray; | ||||
448 | 1551 | 4653 | return 0; | ||||
449 | } | ||||||
450 | 1006219 | 1043108 | if ($version->version() =~ m/^[^\d]/) { | ||||
451 | 3111 | 4148 | my $msg = g_('version number does not start with digit'); | ||||
452 | 3111 | 4673 | return (0, $msg) if wantarray; | ||||
453 | 3102 | 6721 | return 0; | ||||
454 | } | ||||||
455 | 1003108 | 1687523 | if ($str =~ m/([^-+:.0-9a-zA-Z~])/o) { | ||||
456 | 1551 | 3619 | my $msg = sprintf g_("version number contains illegal character '%s'"), $1; | ||||
457 | 1551 | 2068 | return (0, $msg) if wantarray; | ||||
458 | 1551 | 4136 | return 0; | ||||
459 | } | ||||||
460 | 1001557 | 944236 | if ($version->epoch() !~ /^\d*$/) { | ||||
461 | 3102 | 6721 | my $msg = sprintf(g_('epoch part of the version number ' . | ||||
462 | "is not a number: '%s'"), $version->epoch()); | ||||||
463 | 3102 | 3619 | return (0, $msg) if wantarray; | ||||
464 | 3102 | 7238 | return 0; | ||||
465 | } | ||||||
466 | 998455 | 1193704 | return (1, '') if wantarray; | ||||
467 | 997507 | 1817090 | return 1; | ||||
468 | } | ||||||
469 | |||||||
470 | =back | ||||||
471 | |||||||
472 - 492 | =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 | ||||||
493 | |||||||
494 | 1; |