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