Debbugs/Versions/Dpkg.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # Copyright Colin Watson <cjwatson@debian.org>
   7 # Copyright Ian Jackson <iwj@debian.org>
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10
  11 package Debbugs::Versions::Dpkg;
  12
  13 use strict;
  14
  15 =head1 NAME
  16
  17 Debbugs::Versions::Dpkg - pure-Perl dpkg-style version comparison
  18
  19 =head1 DESCRIPTION
  20
  21 The Debbugs::Versions::Dpkg module provides pure-Perl routines to compare
  22 dpkg-style version numbers, as used in Debian packages. If you have the
  23 libapt-pkg Perl bindings available (Debian package libapt-pkg-perl), they
  24 may offer better performance.
  25
  26 =head1 METHODS
  27
  28 =over 8
  29
  30 =cut
  31
  32 sub parseversion ($)
  33 {
  34     my $ver = shift;
  35     my %verhash;
  36     if ($ver =~ /:/)
  37     {
  38         $ver =~ /^(\d+):(.+)/ or die "bad version number '$ver'";
  39         $verhash{epoch} = $1;
  40         $ver = $2;
  41     }
  42     else
  43     {
  44         $verhash{epoch} = 0;
  45     }
  46     if ($ver =~ /(.+)-(.*)$/)
  47     {
  48         $verhash{version} = $1;
  49         $verhash{revision} = $2;
  50     }
  51     else
  52     {
  53         $verhash{version} = $ver;
  54         $verhash{revision} = 0;
  55     }
  56     return %verhash;
  57 }
  58
  59 # verrevcmp
  60
  61 # This function is almost exactly equivalent
  62 # to dpkg's verrevcmp function, including the
  63 # order subroutine which it uses.
  64
  65 sub verrevcmp($$)
  66 {
  67
  68      sub order{
  69           my ($x) = @_;
  70           ##define order(x) ((x) == '~' ? -1 \
  71           #           : cisdigit((x)) ? 0 \
  72           #           : !(x) ? 0 \
  73           #           : cisalpha((x)) ? (x) \
  74           #           : (x) + 256)
  75           # This comparison is out of dpkg's order to avoid
  76           # comparing things to undef and triggering warnings.
  77           if (not defined $x or not length $x) {
  78                return 0;
  79           }
  80           elsif ($x eq '~') {
  81                return -1;
  82           }
  83           elsif ($x =~ /^\d$/) {
  84                return 0;
  85           }
  86           elsif ($x =~ /^[A-Z]$/i) {
  87                return ord($x);
  88           }
  89           else {
  90                return ord($x) + 256;
  91           }
  92      }
  93
  94      sub next_elem(\@){
  95           my $a = shift;
  96           return @{$a} ? shift @{$a} : undef;
  97      }
  98      my ($val, $ref) = @_;
  99      $val = "" if not defined $val;
 100      $ref = "" if not defined $ref;
 101      my @val = split //,$val;
 102      my @ref = split //,$ref;
 103      my $vc = next_elem @val;
 104      my $rc = next_elem @ref;
 105      while (defined $vc or defined $rc) {
 106           my $first_diff = 0;
 107           while ((defined $vc and $vc !~ /^\d$/) or
 108                  (defined $rc and $rc !~ /^\d$/)) {
 109                my $vo = order($vc); my $ro = order($rc);
 110                # Unlike dpkg's verrevcmp, we only return 1 or -1 here.
 111                return (($vo - $ro > 0) ? 1 : -1) if $vo != $ro;
 112                $vc = next_elem @val; $rc = next_elem @ref;
 113           }
 114           while (defined $vc and $vc eq '0') {
 115                $vc = next_elem @val;
 116           }
 117           while (defined $rc and $rc eq '0') {
 118                $rc = next_elem @ref;
 119           }
 120           while (defined $vc and $vc =~ /^\d$/ and
 121                  defined $rc and $rc =~ /^\d$/) {
 122                $first_diff = ord($vc) - ord($rc) if !$first_diff;
 123                $vc = next_elem @val; $rc = next_elem @ref;
 124           }
 125           return 1 if defined $vc and $vc =~ /^\d$/;
 126           return -1 if defined $rc and $rc =~ /^\d$/;
 127           return (($first_diff  > 0) ? 1 : -1) if $first_diff;
 128      }
 129      return 0;
 130 }
 131
 132 =item vercmp
 133
 134 Compare the two arguments as dpkg-style version numbers. Returns -1 if the
 135 first argument represents a lower version number than the second, 1 if the
 136 first argument represents a higher version number than the second, and 0 if
 137 the two arguments represent equal version numbers.
 138
 139 =cut
 140
 141 sub vercmp ($$)
 142 {
 143     my %version = parseversion $_[0];
 144     my %refversion = parseversion $_[1];
 145     return 1 if $version{epoch} > $refversion{epoch};
 146     return -1 if $version{epoch} < $refversion{epoch};
 147     my $r = verrevcmp($version{version}, $refversion{version});
 148     return $r if $r;
 149     return verrevcmp($version{revision}, $refversion{revision});
 150 }
 151
 152 =back
 153
 154 =head1 AUTHOR
 155
 156 Don Armstrong <don@donarmstrong.com> and Colin Watson
 157 E<lt>cjwatson@debian.orgE<gt>, based on the implementation in
 158 C<dpkg/lib/vercmp.c> by Ian Jackson and others.
 159
 160 =cut
 161
 162 1;