Debbugs/Versions/Dpkg.pm

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