]> git.deb.at Git - deb/packages.git/blob - lib/Deb/Versions.pm
Big CSS cleanup, move all style definitions to CSS files.
[deb/packages.git] / 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 use Carp qw(cluck);
68
69 our @ISA = qw( Exporter );
70 our @EXPORT = qw( version_cmp version_sort suites_cmp suites_sort );
71
72 our $VERSION = v1.0.0;
73
74 sub version_cmp {
75     my ( $ver1, $ver2 ) = @_;
76
77     my ( $e1, $e2, $u1, $u2, $d1, $d2 );
78     my $re = qr/^(?:(\d+):)?([\w.+:~-]+?)(?:-([\w+.~]+))?$/;
79     if ( $ver1 =~ $re ) {
80         ( $e1, $u1, $d1 ) = ( $1, $2, $3 );
81         $e1 ||= 0;
82     } else {
83         cluck "This seems not to be a valid version number:"
84             . "<$ver1>\n";
85         return -1;
86     }
87     if ( $ver2 =~ $re ) {
88         ( $e2, $u2, $d2 ) = ( $1, $2, $3 );
89         $e2 ||= 0;
90     } else {
91         cluck "This seems not to be a valid version number:"
92             . "<$ver2>\n";
93         return 1;
94     }
95
96 #    warn "D: <$e1><$u1><$d1> <=> <$e2><$u2><$d2>\n";
97
98     my $res = ($e1 <=> $e2);
99     return $res if $res;
100     $res = _cmp_part ( $u1, $u2 );
101     return $res if $res;
102     $res = _cmp_part ( $d1, $d2 );
103     return $res;
104 }
105
106 sub version_sort {
107     return sort { version_cmp( $b, $a ) } @_;
108 }
109
110 sub _cmp_part {
111     my ( $v1, $v2 ) = @_;
112     my $r;
113
114     while ( $v1 && $v2 ) {
115         $v1 =~ s/^(\D*)//o;
116         my $sp1 = $1;
117         $v2 =~ s/^(\D*)//o;
118         my $sp2 = $1;
119 #       warn "$sp1 cmp $sp2 = "._lcmp( $sp1,$sp2)."\n";
120         if ( $r = _lcmp( $sp1, $sp2 ) ) {
121             return $r;
122         }
123         $v1 =~ s/^(\d*)//o;
124         my $np1 = $1 || 0;
125         $v2 =~ s/^(\d*)//o;
126         my $np2 = $1 || 0;
127 #       warn "$np1 <=> $np2 = ".($np1 <=> $np2)."\n";
128         if ( $r = ($np1 <=> $np2) ) {
129             return $r;
130         }
131     }
132     if ( $v1 || $v2 ) {
133         return $v1 ? 1 : -1;
134     }
135
136     return 0;
137 }
138
139 sub _lcmp {
140     my ( $v1, $v2 ) = @_;
141     
142     for ( my $i = 0; $i < length( $v1 ); $i++ ) {
143         my ( $n1, $n2 ) = ( ord( substr( $v1, $i, 1 ) ), 
144                             ord( substr( $v2, $i, 1 ) ) );
145         $n1 += 256 if $n1 < 65; # letters sort earlier than non-letters
146         $n1 = -1 if $n1 == 126; # '~' sorts earlier than everything else
147         $n2 += 256 if $n2 < 65;
148         $n2 = -1 if $n2 == 126;
149         if ( my $r = ($n1 <=> $n2) ) {
150             return $r;
151         }
152     }
153     return length( $v1 ) <=> length( $v2 );
154 }
155
156 our @SUITES_SORT = qw( woody oldstable sarge stable stable-proposed-updates
157                        etch testing testing-proposed-updates sid unstable
158                        experimental warty hoary hoary-backports breezy
159                        breezy-backports dapper );
160 our @ARCHIVE_SORT = qw( non-US security updates volatile backports );
161 our @PRIORITY_SORT = qw( required important standard optional extra );
162 my $i = 1000;
163 our %suites_sort = map { $_ => ($i-=10) } @SUITES_SORT;
164 our %priority_sort = map { $_ => $i-- } @PRIORITY_SORT;
165 $i = 0;
166 our %archive_sort = map { $_ => $i++ } @ARCHIVE_SORT;
167
168 sub suites_cmp {
169     my ($s_a, $s_b) = @_;
170     my $cmp_a = $suites_sort{$s_a};
171     unless ($cmp_a) {
172         $cmp_a = $suites_sort{$1} - $archive_sort{$2}
173         if $s_a =~ m;^(.+?)[/-](.*)$;o;
174     }
175     my $cmp_b = $suites_sort{$s_b};
176     unless ($cmp_b) {
177         $cmp_b = $suites_sort{$1} - $archive_sort{$2}
178         if $s_b =~ m;^(.+?)[/-](.*)$;o;
179     }
180     return ($cmp_a <=> $cmp_b);
181 }
182
183 sub suites_sort {
184     return sort { suites_cmp( $b, $a ) } @_;
185 }
186
187 sub priority_cmp {
188     return ($priority_sort{$_[0]} <=> $priority_sort{$_[1]});
189 }
190
191 sub priority_sort {
192     return sort { priority_cmp( $b, $a ) } @_;
193 }
194
195
196 1;
197 __END__
198
199 =head1 COPYRIGHT
200
201 Copyright 2003, 2004 Frank Lichtenheld <frank@lichtenheld.de>
202
203 This file is distributed under the terms of the GNU Public
204 License, Version 2. See the source code for more details.
205
206 =head1 SEE ALSO
207
208 Debian policy <URL:http://www.debian.org/doc/debian-policy/>