lib/Deb/Versions.pm

   1 #
   2 # Deb::Versions
   3 #
   4 # Copyright 2003, 2004 Frank Lichtenheld <frank@lichtenheld.de>
   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, write to the Free Software
  18 #    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19 #
  20
  21 =head1 NAME
  22
  23 Deb::Versions - compare Versions of Debian packages
  24
  25 =head1 SYNOPSIS
  26
  27     use Deb::Versions
  28
  29     my $res = version_cmp( "1:0.2.2-2woody1", "1:0.2.3-7" );
  30
  31     my @sorted = version_sort( "1:0.2.2-2woody1", "1:0.2.3-7", "2:0.1.1" );
  32
  33 =head1 DESCRIPTION
  34
  35 This module allows you to compare version numbers like defined
  36 in the Debian policy, section 5.6.11 (L<SEE ALSO>).
  37
  38 It provides two functions:
  39
  40 =over 4
  41
  42 =item *
  43
  44 version_cmp() gets two version strings as parameters and returns
  45 -1, if the first is lower than the second, 0 if equal, 1 if greater.
  46 You can use this function as first parameter for the sort() function.
  47
  48 =item *
  49
  50 version_sort() is just an usefull abbrevation for
  51
  52     sort { version_cmp( $b, $a ) } @_;
  53
  54 =back
  55
  56 =head1 EXPORTS
  57
  58 By default, Deb::Versions exports version_cmp() and version_sort().
  59
  60 =cut
  61
  62 package Deb::Versions;
  63
  64 use strict;
  65 use Exporter;
  66 use Carp qw(cluck);
  67
  68 our @ISA = qw( Exporter );
  69 our @EXPORT = qw( version_cmp version_sort suites_cmp suites_sort );
  70
  71 our $VERSION = v1.0.0;
  72
  73 BEGIN {
  74     eval {
  75         use AptPkg::Config '$_config';
  76         use AptPkg::System '$_system';
  77         use AptPkg::Version;
  78
  79         $_config->init;
  80         $_system = $_config->system;
  81         my $apt_ver = $_system->versioning;
  82         *version_cmp = sub { return $apt_ver->compare(@_) };
  83     };
  84     unless( *version_cmp ){
  85         *version_cmp = \&version_cmp_pp;
  86     }
  87 }
  88
  89 my $re = qr/^(?:(\d+):)?([\w.+:~-]+?)(?:-([\w+.~]+))?$/;
  90 sub version_cmp_pp {
  91     return 0 if $_[0] eq $_[1];
  92     my ( $ver1, $ver2 ) = @_;
  93
  94     my ( $e1, $e2, $u1, $u2, $d1, $d2 );
  95     if ( $ver1 =~ $re ) {
  96         ( $e1, $u1, $d1 ) = ( $1, $2, $3 );
  97         $e1 ||= 0;
  98     } else {
  99         cluck "This seems not to be a valid version number:"
 100             . "<$ver1>\n";
 101         return -1;
 102     }
 103     if ( $ver2 =~ $re ) {
 104         ( $e2, $u2, $d2 ) = ( $1, $2, $3 );
 105         $e2 ||= 0;
 106     } else {
 107         cluck "This seems not to be a valid version number:"
 108             . "<$ver2>\n";
 109         return 1;
 110     }
 111
 112 #    warn "D: <$e1><$u1><$d1> <=> <$e2><$u2><$d2>\n";
 113
 114     my $res = ($e1 <=> $e2);
 115     return $res if $res;
 116     $res = _cmp_part ( $u1, $u2 );
 117     return $res if $res;
 118     $res = _cmp_part ( $d1, $d2 );
 119     return $res;
 120 }
 121
 122 sub version_sort {
 123     return sort { version_cmp( $b, $a ) } @_;
 124 }
 125
 126 sub _cmp_part {
 127     my ( $v1, $v2 ) = @_;
 128     my $r;
 129
 130     while ( $v1 || $v2 ) {
 131         $v1 =~ s/^(\D*)//o;
 132         my $sp1 = $1;
 133         $v2 =~ s/^(\D*)//o;
 134         my $sp2 = $1;
 135 #       warn "$sp1 cmp $sp2 = "._lcmp( $sp1,$sp2)."\n";
 136         if ( $r = _lcmp( $sp1, $sp2 ) ) {
 137             return $r;
 138         }
 139         $v1 =~ s/^(\d*)//o;
 140         my $np1 = $1 || 0;
 141         $v2 =~ s/^(\d*)//o;
 142         my $np2 = $1 || 0;
 143 #       warn "$np1 <=> $np2 = ".($np1 <=> $np2)."\n";
 144         if ( $r = ($np1 <=> $np2) ) {
 145             return $r;
 146         }
 147     }
 148     if ( $v1 || $v2 ) {
 149         return $v1 ? 1 : -1;
 150     }
 151
 152     return 0;
 153 }
 154
 155 sub _lcmp {
 156     my ( $v1, $v2 ) = @_;
 157
 158     for ( my $i = 0; $i <= length( $v1 ); $i++ ) {
 159         my ( $n1, $n2 ) = ( ord( substr( $v1, $i, 1 ) ),
 160                             ord( substr( $v2, $i, 1 ) ) );
 161         $n1 += 256 if $n1 && $n1 < 65; # letters sort earlier than non-letters
 162         $n1 = -1 if $n1 == 126; # '~' sorts earlier than everything else
 163         $n2 += 256 if $n2 && $n2 < 65;
 164         $n2 = -1 if $n2 == 126;
 165         if ( my $r = ($n1 <=> $n2) ) {
 166             return $r;
 167         }
 168     }
 169     return length( $v1 ) <=> length( $v2 );
 170 }
 171
 172 our @SUITES_SORT = qw(  woody
 173                         sarge
 174                         oldstable
 175                         etch etch-m68k
 176                         stable stable-proposed-updates
 177                         lenny
 178                         testing testing-proposed-updates
 179                         squeeze
 180                         sid unstable experimental
 181                         warty hoary breezy dapper edgy feisty gutsy hardy intrepid jaunty);
 182 our @ARCHIVE_SORT = qw( non-US security updates volatile backports );
 183 our @PRIORITY_SORT = qw( required important standard optional extra );
 184 my $i = 1000;
 185 our %suites_sort = map { $_ => ($i-=10) } @SUITES_SORT;
 186 our %priority_sort = map { $_ => $i-- } @PRIORITY_SORT;
 187 $i = 0;
 188 our %archive_sort = map { $_ => $i++ } @ARCHIVE_SORT;
 189
 190 sub suites_cmp {
 191     my ($s_a, $s_b) = @_;
 192     my $cmp_a = $suites_sort{$s_a};
 193     unless ($cmp_a) {
 194         $cmp_a = $suites_sort{$1} - $archive_sort{$2}
 195         if $s_a =~ m;^(.+?)[/-](.*)$;o;
 196     }
 197     my $cmp_b = $suites_sort{$s_b};
 198     unless ($cmp_b) {
 199         $cmp_b = $suites_sort{$1} - $archive_sort{$2}
 200         if $s_b =~ m;^(.+?)[/-](.*)$;o;
 201     }
 202     return ($cmp_b <=> $cmp_a);
 203 }
 204
 205 sub suites_sort {
 206     return sort { suites_cmp( $a, $b ) } @_;
 207 }
 208
 209 sub priority_cmp {
 210     return ($priority_sort{$_[0]} <=> $priority_sort{$_[1]});
 211 }
 212
 213 sub priority_sort {
 214     return sort { priority_cmp( $b, $a ) } @_;
 215 }
 216
 217
 218 1;
 219 __END__
 220
 221 =head1 COPYRIGHT
 222
 223 Copyright 2003, 2004 Frank Lichtenheld <frank@lichtenheld.de>
 224
 225 This file is distributed under the terms of the GNU Public
 226 License, Version 2. See the source code for more details.
 227
 228 =head1 SEE ALSO
 229
 230 Debian policy <URL:http://www.debian.org/doc/debian-policy/>