lib/WannaBuild.pm

   1 #
   2 # WannaBuild.pm: library for wanna-build and sbuild
   3 # Copyright (C) 2005 Ryan Murray <rmurray@debian.org>
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License as
   7 # published by the Free Software Foundation; either version 2 of the
   8 # License, or (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  18 #
  19 # $Id$
  20 #
  21
  22 package WannaBuild;
  23
  24 use strict;
  25 use POSIX;
  26 use FileHandle;
  27 use Time::Local;
  28
  29 require Exporter;
  30 @WannaBuild::ISA = qw(Exporter);
  31 @WannaBuild::EXPORT = qw(version_less version_lesseq version_eq
  32                         version_compare binNMU_version parse_date isin);
  33
  34 $WannaBuild::opt_correct_version_cmp = 0;
  35
  36 sub version_less {
  37         my $v1 = shift;
  38         my $v2 = shift;
  39
  40         return version_compare( $v1, "<<", $v2 );
  41 }
  42
  43 sub version_lesseq {
  44         my $v1 = shift;
  45         my $v2 = shift;
  46
  47         return version_compare( $v1, "<=", $v2 );
  48 }
  49
  50 sub version_eq {
  51         my $v1 = shift;
  52         my $v2 = shift;
  53
  54         return version_compare( $v1, "=", $v2 );
  55 }
  56
  57 sub version_compare {
  58         my $v1 = shift;
  59         my $rel = shift;
  60         my $v2 = shift;
  61
  62         if ($WannaBuild::opt_correct_version_cmp) {
  63                 system "dpkg", "--compare-versions", $v1, $rel, $v2;
  64                 return $? == 0;
  65         }
  66         else {
  67                 if ($rel eq "=" || $rel eq "==") {
  68                         return $v1 eq $v2;
  69                 }
  70                 elsif ($rel eq "<<") {
  71                         return do_version_cmp( $v1, $v2 );
  72                 }
  73                 elsif ($rel eq "<=" || $rel eq "<") {
  74                         return $v1 eq $v2 || do_version_cmp( $v1, $v2 );
  75                 }
  76                 elsif ($rel eq ">=" || $rel eq ">") {
  77                         return !do_version_cmp( $v1, $v2 );
  78                 }
  79                 elsif ($rel eq ">>") {
  80                         return $v1 ne $v2 && !do_version_cmp( $v1, $v2 );
  81                 }
  82                 else {
  83                         warn "version_compare called with bad relation '$rel'\n";
  84                         return $v1 eq $2;
  85                 }
  86         }
  87 }
  88
  89 sub do_version_cmp {
  90         my($versa, $versb) = @_;
  91         my($epocha,$upstra,$reva);
  92         my($epochb,$upstrb,$revb);
  93         my($r);
  94
  95         ($epocha,$upstra,$reva) = split_version($versa);
  96         ($epochb,$upstrb,$revb) = split_version($versb);
  97
  98         # compare epochs
  99         return 1 if $epocha < $epochb;
 100         return 0 if $epocha > $epochb;
 101
 102         # compare upstream versions
 103         $r = version_cmp_single( $upstra, $upstrb );
 104         return $r < 0 if $r != 0;
 105
 106         # compare Debian revisions
 107         $r = version_cmp_single( $reva, $revb );
 108         return $r < 0;
 109 }
 110
 111 sub order {
 112         for ($_[0])
 113         {
 114         /\~/     and return -1;
 115         /\d/     and return  0;
 116         /[a-z]/i and return ord;
 117                      return (ord) + 256;
 118         }
 119 }
 120
 121 sub version_cmp_single {
 122         my($versa, $versb) = @_;
 123         my($a,$b,$lena,$lenb,$va,$vb,$i);
 124
 125         for(;;) {
 126                 # compare non-numeric parts
 127                 $versa =~ /^([^\d]*)(.*)/; $a = $1; $versa = $2;
 128                 $versb =~ /^([^\d]*)(.*)/; $b = $1; $versb = $2;
 129                 $lena = length($a);
 130                 $lenb = length($b);
 131                 for( $i = 0; $i < $lena || $i < $lenb; ++$i ) {
 132                         $va = $i < $lena ? order(substr( $a, $i, 1 )) : 0;
 133                         $vb = $i < $lenb ? order(substr( $b, $i, 1 )) : 0;
 134                         return $va - $vb if $va != $vb;
 135                 }
 136                 # compare numeric parts
 137                 $versa =~ /^(\d*)(.*)/; $a = $1; $a ||= 0; $versa = $2;
 138                 $versb =~ /^(\d*)(.*)/; $b = $1; $b ||= 0; $versb = $2;
 139                 return $a - $b if $a != $b;
 140                 return 0 if !$versa && !$versb;
 141                 if (!$versa) {
 142                         return +1 if order(substr( $versb, 0, 1 ) ) < 0;
 143                         return -1;
 144                 }
 145                 if (!$versb) {
 146                         return -1 if order(substr( $versa, 0, 1 ) ) < 0;
 147                         return +1;
 148                 }
 149         }
 150 }
 151
 152 sub split_version {
 153         my($vers) = @_;
 154         my($epoch,$revision) = (0,"");
 155
 156         if ($vers =~ /^(\d+):(.*)/) {
 157                 $epoch = $1;
 158                 $vers = $2;
 159         }
 160
 161         if ($vers =~ /(.*)-([^-]+)$/) {
 162                 $revision = $2;
 163                 $vers = $1;
 164         }
 165
 166         return( $epoch, $vers, $revision );
 167 }
 168
 169 sub binNMU_version {
 170         my $v = shift;
 171         my $binNMUver = shift;
 172
 173         return "$v+b$binNMUver" if $binNMUver;
 174         return $v;
 175 }
 176
 177
 178 my %monname = ('jan', 0, 'feb', 1, 'mar', 2, 'apr', 3, 'may', 4, 'jun', 5,
 179                 'jul', 6, 'aug', 7, 'sep', 8, 'oct', 9, 'nov', 10, 'dec', 11 );
 180
 181 sub parse_date {
 182         my $text = shift;
 183
 184         return 0 if !$text;
 185
 186         if ($text =~ /^(\d{4}) (\w{3}) (\d+) (\d{2}):(\d{2}):(\d{2})$/) {
 187                 my ($year, $mon, $day, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6);
 188                 $mon =~ y/A-Z/a-z/;
 189                 die "Invalid month name $mon" if !exists $monname{$mon};
 190                 $mon = $monname{$mon};
 191                 return timegm($sec, $min, $hour, $day, $mon, $year);
 192         } elsif ($text =~ /^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})(?:\.\d+)?$/) {
 193                 my ($year, $mon, $day, $hour, $min, $sec) = ($1, $2-1, $3, $4, $5, $6);
 194                 return timegm($sec, $min, $hour, $day, $mon, $year);
 195         } else {
 196                 die "Cannot parse date: $text\n";
 197         }
 198 }
 199
 200 sub isin {
 201         my $val = shift;
 202
 203         return 0 if !$val;
 204
 205         return grep( $_ eq $val, @_ );
 206 }
 207
 208 #sub get_distributions {
 209 #       my %distributions;
 210
 211 #       my $q = 'SELECT distribution, public, auto_dep_wait FROM distributions';
 212 #       my $rows = $dbh->selectall_hashref($q, 'distribution');
 213 #       foreach my $name (keys %$rows) {
 214 #               $distributions{$name} = {};
 215 #               $distributions{$name}->{'noadw'} = 1 if ($rows->{$name}->{'auto_dep_wait'});
 216 #               $distributions{$name}->{'hidden'} = 1 if ($rows->{$name}->{'public'});
 217 #       }
 218
 219 #       return %distributions;
 220 #}
 221
 222 1;