File Coverage

File:Dpkg/Version.pm
Coverage:93.5%

linestmtbrancondsubpodtimecode
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
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
25our $VERSION = '1.03';
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
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
47use constant {
48
541
47034
    REL_LT => '<<',
49    REL_LE => '<=',
50    REL_EQ => '=',
51    REL_GE => '>=',
52    REL_GT => '>>',
53
541
541
1594
13
};
54
55use 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
93sub 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
146sub 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
157sub epoch {
158
1616844
1
1438009
    my $self = shift;
159
1616844
3525783
    return $self->{epoch};
160}
161
162sub version {
163
1569462
1
1193130
    my $self = shift;
164
1569462
2886659
    return $self->{version};
165}
166
167sub 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
178sub 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
191sub _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
226sub 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
255sub 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
275sub 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
304sub 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
338sub _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
352sub 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
376sub 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
404sub 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
420sub 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
4911;