lib/Deb/Versions.pm

   1 #
   2 # Deb::Versions
   3 # $Id$
   4 #
   5 # Copyright 2003, 2004 Frank Lichtenheld <frank@lichtenheld.de>
   6 #
   7 #    This program is free software; you can redistribute it and/or modify
   8 #    it under the terms of the GNU General Public License as published by
   9 #    the Free Software Foundation; either version 2 of the License, or
  10 #    (at your option) any later version.
  11 #
  12 #    This program is distributed in the hope that it will be useful,
  13 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 #    GNU General Public License for more details.
  16 #
  17 #    You should have received a copy of the GNU General Public License
  18 #    along with this program; if not, write to the Free Software
  19 #    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20 #
  21
  22 =head1 NAME
  23
  24 Deb::Versions - compare Versions of Debian packages
  25
  26 =head1 SYNOPSIS
  27
  28     use Deb::Versions
  29
  30     my $res = version_cmp( "1:0.2.2-2woody1", "1:0.2.3-7" );
  31
  32     my @sorted = version_sort( "1:0.2.2-2woody1", "1:0.2.3-7", "2:0.1.1" );
  33
  34 =head1 DESCRIPTION
  35
  36 This module allows you to compare version numbers like defined
  37 in the Debian policy, section 5.6.11 (L<SEE ALSO>).
  38
  39 It provides two functions:
  40
  41 =over 4
  42
  43 =item *
  44
  45 version_cmp() gets two version strings as parameters and returns
  46 -1, if the first is lower than the second, 0 if equal, 1 if greater.
  47 You can use this function as first parameter for the sort() function.
  48
  49 =item *
  50
  51 version_sort() is just an usefull abbrevation for
  52
  53     sort { version_cmp( $b, $a ) } @_;
  54
  55 =back
  56
  57 =head1 EXPORTS
  58
  59 By default, Deb::Versions exports version_cmp() and version_sort().
  60
  61 =cut
  62
  63 package Deb::Versions;
  64
  65 use strict;
  66 use Exporter;
  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 sub version_cmp {
  74     my ( $ver1, $ver2 ) = @_;
  75
  76     my ( $e1, $e2, $u1, $u2, $d1, $d2 );
  77     my $re = qr/^(?:(\d+):)?([\w.+:~-]+?)(?:-([\w+.~]+))?$/;
  78     if ( $ver1 =~ $re ) {
  79         ( $e1, $u1, $d1 ) = ( $1, $2, $3 );
  80         $e1 ||= 0;
  81     } else {
  82         warn "This seems not to be a valid version number:"
  83             . "<$ver1>\n";
  84         return -1;
  85     }
  86     if ( $ver2 =~ $re ) {
  87         ( $e2, $u2, $d2 ) = ( $1, $2, $3 );
  88         $e2 ||= 0;
  89     } else {
  90         warn "This seems not to be a valid version number:"
  91             . "<$ver2>\n";
  92         return 1;
  93     }
  94
  95 #    warn "D: <$e1><$u1><$d1> <=> <$e2><$u2><$d2>\n";
  96
  97     my $res = ($e1 <=> $e2);
  98     return $res if $res;
  99     $res = _cmp_part ( $u1, $u2 );
 100     return $res if $res;
 101     $res = _cmp_part ( $d1, $d2 );
 102     return $res;
 103 }
 104
 105 sub version_sort {
 106     return sort { version_cmp( $b, $a ) } @_;
 107 }
 108
 109 sub _cmp_part {
 110     my ( $v1, $v2 ) = @_;
 111     my $r;
 112
 113     while ( $v1 && $v2 ) {
 114         $v1 =~ s/^(\D*)//o;
 115         my $sp1 = $1;
 116         $v2 =~ s/^(\D*)//o;
 117         my $sp2 = $1;
 118 #       warn "$sp1 cmp $sp2 = "._lcmp( $sp1,$sp2)."\n";
 119         if ( $r = _lcmp( $sp1, $sp2 ) ) {
 120             return $r;
 121         }
 122         $v1 =~ s/^(\d*)//o;
 123         my $np1 = $1 || 0;
 124         $v2 =~ s/^(\d*)//o;
 125         my $np2 = $1 || 0;
 126 #       warn "$np1 <=> $np2 = ".($np1 <=> $np2)."\n";
 127         if ( $r = ($np1 <=> $np2) ) {
 128             return $r;
 129         }
 130     }
 131     if ( $v1 || $v2 ) {
 132         return $v1 ? 1 : -1;
 133     }
 134
 135     return 0;
 136 }
 137
 138 sub _lcmp {
 139     my ( $v1, $v2 ) = @_;
 140
 141     for ( my $i = 0; $i < length( $v1 ); $i++ ) {
 142         my ( $n1, $n2 ) = ( ord( substr( $v1, $i, 1 ) ),
 143                             ord( substr( $v2, $i, 1 ) ) );
 144         $n1 += 256 if $n1 < 65; # letters sort earlier than non-letters
 145         $n1 = -1 if $n1 == 126; # '~' sorts earlier than everything else
 146         $n2 += 256 if $n2 < 65;
 147         $n2 = -1 if $n2 == 126;
 148         if ( my $r = ($n1 <=> $n2) ) {
 149             return $r;
 150         }
 151     }
 152     return length( $v1 ) <=> length( $v2 );
 153 }
 154
 155 our @SUITES_SORT = qw( woody oldstable sarge stable stable-proposed-updates
 156                        etch testing testing-proposed-updates sid unstable
 157                        experimental warty hoary hoary-backports breezy
 158                        breezy-backports dapper );
 159 my $i = 100;
 160 our %suites_sort = map { $_ => $i-- } @SUITES_SORT;
 161
 162 sub suites_cmp {
 163     return ($suites_sort{$_[0]} <=> $suites_sort{$_[1]});
 164 }
 165
 166 sub suites_sort {
 167     return sort { suites_cmp( $b, $a ) } @_;
 168 }
 169
 170
 171 1;
 172 __END__
 173
 174 =head1 COPYRIGHT
 175
 176 Copyright 2003, 2004 Frank Lichtenheld <frank@lichtenheld.de>
 177
 178 This file is distributed under the terms of the GNU Public
 179 License, Version 2. See the source code for more details.
 180
 181 =head1 SEE ALSO
 182
 183 Debian policy <URL:http://www.debian.org/doc/debian-policy/>