Commit | Line | Data |
---|---|---|
1479465f GJ |
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; |