Comment clean-up: Remove $Id$, fix FSF address, copyright years
[deb/packages.git] / 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 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         cluck "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         cluck "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 && $n1 < 65; # letters sort earlier than non-letters
145         $n1 = -1 if $n1 == 126; # '~' sorts earlier than everything else
146         $n2 += 256 if $n2 && $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 etch-m68k testing testing-proposed-updates lenny
157                        sid unstable experimental
158                        warty hoary breezy breezy dapper edgy feisty gutsy );
159 our @ARCHIVE_SORT = qw( non-US security updates volatile backports );
160 our @PRIORITY_SORT = qw( required important standard optional extra );
161 my $i = 1000;
162 our %suites_sort = map { $_ => ($i-=10) } @SUITES_SORT;
163 our %priority_sort = map { $_ => $i-- } @PRIORITY_SORT;
164 $i = 0;
165 our %archive_sort = map { $_ => $i++ } @ARCHIVE_SORT;
166
167 sub suites_cmp {
168     my ($s_a, $s_b) = @_;
169     my $cmp_a = $suites_sort{$s_a};
170     unless ($cmp_a) {
171         $cmp_a = $suites_sort{$1} - $archive_sort{$2}
172         if $s_a =~ m;^(.+?)[/-](.*)$;o;
173     }
174     my $cmp_b = $suites_sort{$s_b};
175     unless ($cmp_b) {
176         $cmp_b = $suites_sort{$1} - $archive_sort{$2}
177         if $s_b =~ m;^(.+?)[/-](.*)$;o;
178     }
179     return ($cmp_a <=> $cmp_b);
180 }
181
182 sub suites_sort {
183     return sort { suites_cmp( $b, $a ) } @_;
184 }
185
186 sub priority_cmp {
187     return ($priority_sort{$_[0]} <=> $priority_sort{$_[1]});
188 }
189
190 sub priority_sort {
191     return sort { priority_cmp( $b, $a ) } @_;
192 }
193
194
195 1;
196 __END__
197
198 =head1 COPYRIGHT
199
200 Copyright 2003, 2004 Frank Lichtenheld <frank@lichtenheld.de>
201
202 This file is distributed under the terms of the GNU Public
203 License, Version 2. See the source code for more details.
204
205 =head1 SEE ALSO
206
207 Debian policy <URL:http://www.debian.org/doc/debian-policy/>