Index: third_party/dpkg-dev/scripts/Dpkg/Version.pm |
diff --git a/third_party/dpkg-dev/scripts/Dpkg/Version.pm b/third_party/dpkg-dev/scripts/Dpkg/Version.pm |
new file mode 100644 |
index 0000000000000000000000000000000000000000..5461f597fe1d9e6fac00a5ca54ff9b47ceefd55e |
--- /dev/null |
+++ b/third_party/dpkg-dev/scripts/Dpkg/Version.pm |
@@ -0,0 +1,445 @@ |
+# Copyright © Colin Watson <cjwatson@debian.org> |
+# Copyright © Ian Jackson <iwj@debian.org> |
+# Copyright © 2007 Don Armstrong <don@donarmstrong.com>. |
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> |
+# |
+# This program is free software; you can redistribute it and/or modify |
+# it under the terms of the GNU General Public License as published by |
+# the Free Software Foundation; either version 2 of the License, or |
+# (at your option) any later version. |
+# |
+# This program is distributed in the hope that it will be useful, |
+# but WITHOUT ANY WARRANTY; without even the implied warranty of |
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
+# GNU General Public License for more details. |
+# |
+# You should have received a copy of the GNU General Public License |
+# along with this program. If not, see <https://www.gnu.org/licenses/>. |
+ |
+package Dpkg::Version; |
+ |
+use strict; |
+use warnings; |
+ |
+our $VERSION = '1.01'; |
+ |
+use Dpkg::ErrorHandling; |
+use Dpkg::Gettext; |
+ |
+use Carp; |
+use Exporter qw(import); |
+our @EXPORT = qw(version_compare version_compare_relation |
+ version_normalize_relation version_compare_string |
+ version_compare_part version_split_digits version_check |
+ REL_LT REL_LE REL_EQ REL_GE REL_GT); |
+ |
+use constant { |
+ REL_LT => '<<', |
+ REL_LE => '<=', |
+ REL_EQ => '=', |
+ REL_GE => '>=', |
+ REL_GT => '>>', |
+}; |
+ |
+use overload |
+ '<=>' => \&comparison, |
+ 'cmp' => \&comparison, |
+ '""' => sub { return $_[0]->as_string(); }, |
+ 'bool' => sub { return $_[0]->as_string() if $_[0]->is_valid(); }, |
+ 'fallback' => 1; |
+ |
+=encoding utf8 |
+ |
+=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 OBJECT INTERFACE |
+ |
+=over 4 |
+ |
+=item my $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 |
+ |
+sub new { |
+ my ($this, $ver, %opts) = @_; |
+ my $class = ref($this) || $this; |
+ $ver = "$ver" if ref($ver); # Try to stringify objects |
+ |
+ if ($opts{check}) { |
+ return unless version_check($ver); |
+ } |
+ |
+ my $self = {}; |
+ if ($ver =~ /^([^:]*):(.+)$/) { |
+ $self->{epoch} = $1; |
+ $ver = $2; |
+ } else { |
+ $self->{epoch} = 0; |
+ $self->{no_epoch} = 1; |
+ } |
+ if ($ver =~ /(.*)-(.*)$/) { |
+ $self->{version} = $1; |
+ $self->{revision} = $2; |
+ } else { |
+ $self->{version} = $ver; |
+ $self->{revision} = 0; |
+ $self->{no_revision} = 1; |
+ } |
+ |
+ return bless $self, $class; |
+} |
+ |
+=item boolean evaluation |
+ |
+When the Dpkg::Version object is used in a boolean evaluation (for example |
+in "if ($v)" or "$v || 'default'") it returns its string representation |
+if the version stored is valid ($v->is_valid()) and undef otherwise. |
+ |
+=item $v->is_valid() |
+ |
+Returns true if the version is valid, false otherwise. |
+ |
+=cut |
+ |
+sub is_valid { |
+ my ($self) = @_; |
+ return scalar version_check($self); |
+} |
+ |
+=item $v->epoch(), $v->version(), $v->revision() |
+ |
+Returns the corresponding part of the full version string. |
+ |
+=cut |
+ |
+sub epoch { |
+ my $self = shift; |
+ return $self->{epoch}; |
+} |
+ |
+sub version { |
+ my $self = shift; |
+ return $self->{version}; |
+} |
+ |
+sub revision { |
+ my $self = shift; |
+ return $self->{revision}; |
+} |
+ |
+=item $v->is_native() |
+ |
+Returns true if the version is native, false if it has a revision. |
+ |
+=cut |
+ |
+sub is_native { |
+ my $self = shift; |
+ return $self->{no_revision}; |
+} |
+ |
+=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 |
+ |
+sub comparison { |
+ my ($a, $b, $inverted) = @_; |
+ if (not ref($b) or not $b->isa('Dpkg::Version')) { |
+ $b = Dpkg::Version->new($b); |
+ } |
+ ($a, $b) = ($b, $a) if $inverted; |
+ my $r = version_compare_part($a->epoch(), $b->epoch()); |
+ return $r if $r; |
+ $r = version_compare_part($a->version(), $b->version()); |
+ return $r if $r; |
+ return version_compare_part($a->revision(), $b->revision()); |
+} |
+ |
+=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 |
+ |
+sub as_string { |
+ my ($self, %opts) = @_; |
+ my $no_epoch = $opts{omit_epoch} || $self->{no_epoch}; |
+ my $no_revision = $opts{omit_revision} || $self->{no_revision}; |
+ |
+ my $str = ''; |
+ $str .= $self->{epoch} . ':' unless $no_epoch; |
+ $str .= $self->{version}; |
+ $str .= '-' . $self->{revision} unless $no_revision; |
+ return $str; |
+} |
+ |
+=back |
+ |
+=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 |
+ |
+sub version_compare($$) { |
+ my ($a, $b) = @_; |
+ my $va = Dpkg::Version->new($a, check => 1); |
+ defined($va) || error(_g('%s is not a valid version'), "$a"); |
+ my $vb = Dpkg::Version->new($b, check => 1); |
+ defined($vb) || error(_g('%s is not a valid version'), "$b"); |
+ return $va <=> $vb; |
+} |
+ |
+=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 |
+ |
+sub version_compare_relation($$$) { |
+ my ($a, $op, $b) = @_; |
+ my $res = version_compare($a, $b); |
+ |
+ if ($op eq REL_GT) { |
+ return $res > 0; |
+ } elsif ($op eq REL_GE) { |
+ return $res >= 0; |
+ } elsif ($op eq REL_EQ) { |
+ return $res == 0; |
+ } elsif ($op eq REL_LE) { |
+ return $res <= 0; |
+ } elsif ($op eq REL_LT) { |
+ return $res < 0; |
+ } else { |
+ croak "unsupported relation for version_compare_relation(): '$op'"; |
+ } |
+} |
+ |
+=item my $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 |
+ |
+sub version_normalize_relation($) { |
+ my $op = shift; |
+ |
+ warning('relation %s is deprecated: use %s or %s', |
+ $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<'); |
+ |
+ if ($op eq '>>' or $op eq 'gt') { |
+ return REL_GT; |
+ } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') { |
+ return REL_GE; |
+ } elsif ($op eq '=' or $op eq 'eq') { |
+ return REL_EQ; |
+ } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') { |
+ return REL_LE; |
+ } elsif ($op eq '<<' or $op eq 'lt') { |
+ return REL_LT; |
+ } else { |
+ croak "bad relation '$op'"; |
+ } |
+} |
+ |
+=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-Za-z) |
+sort lower than the other ones. Within each range, the ASCII decimal value |
+of the character is used to sort between characters. |
+ |
+=cut |
+ |
+sub _version_order { |
+ my ($x) = @_; |
+ |
+ if ($x eq '~') { |
+ return -1; |
+ } elsif ($x =~ /^\d$/) { |
+ return $x * 1 + 1; |
+ } elsif ($x =~ /^[A-Za-z]$/) { |
+ return ord($x); |
+ } else { |
+ return ord($x) + 256; |
+ } |
+} |
+ |
+sub version_compare_string($$) { |
+ my @a = map { _version_order($_) } split(//, shift); |
+ my @b = map { _version_order($_) } split(//, shift); |
+ while (1) { |
+ my ($a, $b) = (shift @a, shift @b); |
+ return 0 if not defined($a) and not defined($b); |
+ $a ||= 0; # Default order for "no character" |
+ $b ||= 0; |
+ return 1 if $a > $b; |
+ return -1 if $a < $b; |
+ } |
+} |
+ |
+=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 |
+ |
+sub version_compare_part($$) { |
+ my @a = version_split_digits(shift); |
+ my @b = version_split_digits(shift); |
+ while (1) { |
+ my ($a, $b) = (shift @a, shift @b); |
+ return 0 if not defined($a) and not defined($b); |
+ $a ||= 0; # Default value for lack of version |
+ $b ||= 0; |
+ if ($a =~ /^\d+$/ and $b =~ /^\d+$/) { |
+ # Numerical comparison |
+ my $cmp = $a <=> $b; |
+ return $cmp if $cmp; |
+ } else { |
+ # String comparison |
+ my $cmp = version_compare_string($a, $b); |
+ return $cmp if $cmp; |
+ } |
+ } |
+} |
+ |
+=item my @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 |
+ |
+sub version_split_digits($) { |
+ return split(/(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $_[0]); |
+} |
+ |
+=item my ($ok, $msg) = version_check($version) |
+ |
+=item my $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 |
+ |
+sub version_check($) { |
+ my $version = shift; |
+ my $str; |
+ if (defined $version) { |
+ $str = "$version"; |
+ $version = Dpkg::Version->new($str) unless ref($version); |
+ } |
+ if (not defined($str) or not length($str)) { |
+ my $msg = _g('version number cannot be empty'); |
+ return (0, $msg) if wantarray; |
+ return 0; |
+ } |
+ if ($version->version() =~ m/^[^\d]/) { |
+ my $msg = _g('version number does not start with digit'); |
+ return (0, $msg) if wantarray; |
+ return 0; |
+ } |
+ if ($str =~ m/([^-+:.0-9a-zA-Z~])/o) { |
+ my $msg = sprintf(_g("version number contains illegal character `%s'"), $1); |
+ return (0, $msg) if wantarray; |
+ return 0; |
+ } |
+ if ($version->epoch() !~ /^\d*$/) { |
+ my $msg = sprintf(_g('epoch part of the version number ' . |
+ "is not a number: '%s'"), $version->epoch()); |
+ return (0, $msg) if wantarray; |
+ return 0; |
+ } |
+ return (1, '') if wantarray; |
+ return 1; |
+} |
+ |
+=back |
+ |
+=head1 CHANGES |
+ |
+=head2 Version 1.01 |
+ |
+New argument: Accept an options argument in $v->as_string(). |
+ |
+New method: $v->is_native(). |
+ |
+=head1 AUTHOR |
+ |
+Don Armstrong <don@donarmstrong.com>, Colin Watson |
+<cjwatson@debian.org> and Raphaël Hertzog <hertzog@debian.org>, based on |
+the implementation in F<dpkg/lib/version.c> by Ian Jackson and others. |
+ |
+=cut |
+ |
+1; |