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
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
35package 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
42our @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
63use constant {
64
1626
170009
    REL_LT => '<<',
65    REL_LE => '<=',
66    REL_EQ => '=',
67    REL_GE => '>=',
68    REL_GT => '>>',
69
1626
1626
3793
1635
};
70
71use 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
95sub 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
149sub 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
160sub epoch {
161
4850671
1
3760731
    my $self = shift;
162
4850671
10138644
    return $self->{epoch};
163}
164
165sub version {
166
4708525
1
3330352
    my $self = shift;
167
4708525
9382391
    return $self->{version};
168}
169
170sub 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
181sub 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
194sub _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
229sub 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
258sub 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
278sub 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
307sub 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
341sub _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
355sub 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
379sub 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
407sub 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
423sub 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
4941;